diff --git a/.github/workflows/publish-to-test-pypi.yml b/.github/workflows/publish-to-test-pypi.yml new file mode 100644 index 0000000..7ff4ccf --- /dev/null +++ b/.github/workflows/publish-to-test-pypi.yml @@ -0,0 +1,236 @@ +# Workflow developed from Python Package User Guide: +# https://packaging.python.org/en/latest/guides/publishing-package-distribution-releases-using-github-actions-ci-cd-workflows/ + +name: Publish Python 🐍 distribution 📦 to PyPI and TestPyPI + +on: + push: + branches: + - main + tags: + - v* + workflow_dispatch: + +jobs: + check-version-matches: + name: Check if version numbers match the GitHub tag + runs-on: ubuntu-latest + continue-on-error: ${{ github.event_name == 'workflow_dispatch' }} + steps: + - name: Checkout repository + uses: actions/checkout@v4 + + - name: Extract version from fpm.toml + id: fpm_version + run: echo "ARTEMIS_FPM_VERSION=$(awk -F'"' '/^version/ {print $2}' fpm.toml)" >> $GITHUB_ENV + + - name: Extract version from mod_io_utils.F90 + id: fortran_version + run: echo "ARTEMIS_FORTRAN_VERSION=$(awk -F'"' '/character\(len=\*\), parameter \:\:\ artemis__version__/ {print $2}' src/fortran/lib/mod_io_utils.F90)" >> $GITHUB_ENV + + - name: Extract GitHub tag version + id: github_tag + run: echo "TAG_VERSION=${GITHUB_REF#refs/tags/v}" >> "$GITHUB_ENV" + + - name: Verify version consistency + run: | + if [[ "$ARTEMIS_FPM_VERSION" != "$TAG_VERSION" ]]; then + echo "❌ Version mismatch: fpm.toml ($ARTEMIS_FPM_VERSION) does not match GitHub tag ($TAG_VERSION)" + exit 1 + fi + if [[ "$ARTEMIS_FORTRAN_VERSION" != "$TAG_VERSION" ]]; then + echo "❌ Version mismatch: mod_io_utils.F90 ($ARTEMIS_FORTRAN_VERSION) does not match GitHub tag ($TAG_VERSION)" + exit 1 + fi + echo "✅ Version numbers match!" + + build_wheel: + name: Build wheel distribution 📦 + runs-on: ${{ matrix.platform[0] }} + strategy: + fail-fast: false + matrix: + platform: + - [ubuntu-latest, manylinux, x86_64] + - [macos-14, macosx, arm64] + python-version: [ "3.12" ] # cibuildwheel automatically runs on all versions of Python + toolchain: + - {fortran-compiler: gcc, fc-version: 13} + needs: + - check-version-matches + + steps: + - name: checkout repo + uses: actions/checkout@v4 + + - name: Set MACOSX_DEPLOYMENT_TARGET + if: startsWith(matrix.platform[0], 'macos') + run: echo "MACOSX_DEPLOYMENT_TARGET=$(sw_vers -productVersion | cut -d '.' -f 1-2)" >> $GITHUB_ENV + + - name: Check macOS deployment target + if: startsWith(matrix.platform[0], 'macos') + run: echo "Deployment target version is ${{ env.MACOSX_DEPLOYMENT_TARGET }} / ${MACOSX_DEPLOYMENT_TARGET}" + + - name: actions-setup-python ${{ matrix.python-version }} + uses: actions/setup-python@v5 + with: + python-version: ${{ matrix.python-version }} + + - name: actions-setup-cmake + uses: jwlawson/actions-setup-cmake@v2.0.1 + with: + cmake-version: '3.24.x' + + - name: actions-setup-fortran + uses: fortran-lang/setup-fortran@v1 + id: setup-fortran + with: + compiler: ${{ matrix.toolchain.fortran-compiler }} + version: ${{ matrix.toolchain.fc-version }} + + - name: Install OpenMP runtime (Linux only) + if: runner.os == 'Linux' + run: sudo apt-get update && sudo apt-get install -y libgomp1 + + - name: Install OpenMP runtime (macOS only) + if: runner.os == 'macOS' + run: brew install libomp + + - name: Install python dependencies + run: | + python --version + python -m pip install pip-tools --user + python -m pip install build --user + python -m piptools compile -o requirements.txt pyproject.toml --all-build-deps + python -m pip install -r requirements.txt --user + python -m pip install cibuildwheel==2.22.0 --user + + - name: Build a binary wheel distribution + run: python -m cibuildwheel --output-dir wheelhouse + + - name: Store the distribution wheels + uses: actions/upload-artifact@v4 + with: + name: artemis_materials-wheels-${{ matrix.python-version }}-${{ matrix.platform[0] }}-${{ matrix.toolchain.fortran-compiler }}${{ matrix.toolchain.fc-version }} + path: ./wheelhouse/*.whl + + build_sdist: + name: Build wheel distribution 📦 + runs-on: ubuntu-latest + steps: + - name: checkout repo + uses: actions/checkout@v4 + + - name: Build sdist + run: pipx run build --sdist + + - name: Store the source distribution + uses: actions/upload-artifact@v4 + with: + name: artemis_materials-sdist + path: dist/*.tar.gz + + publish-to-pypi: + name: >- + Publish Python 🐍 distribution 📦 to PyPI + if: startsWith(github.ref, 'refs/tags/') # only publish to PyPI on tag pushes + needs: + - build_wheel + - build_sdist + runs-on: ubuntu-latest + environment: + name: pypi + url: https://pypi.org/p/artemis-materials + permissions: + id-token: write # IMPORTANT: mandatory for trusted publishing + + steps: + - name: Download all the dists + uses: actions/download-artifact@v4 + with: + pattern: artemis_materials-* + path: dist + merge-multiple: true + - name: Publish distribution 📦 to PyPI + uses: pypa/gh-action-pypi-publish@release/v1 + + # publish-to-testpypi: + # name: Publish Python 🐍 distribution 📦 to TestPyPI + # if: startsWith(github.ref, 'refs/tags/') # only publish to PyPI on tag pushes + # needs: + # - build_wheel + # - build_sdist + # runs-on: ubuntu-latest + + # environment: + # name: testpypi + # url: https://test.pypi.org/p/artemis-materials + + # permissions: + # id-token: write # IMPORTANT: mandatory for trusted publishing + + # steps: + # - name: Download all the dists + # uses: actions/download-artifact@v4 + # with: + # pattern: artemis_materials-* + # path: dist + # merge-multiple: true + # - name: Publish distribution 📦 to TestPyPI + # uses: pypa/gh-action-pypi-publish@release/v1 + # with: + # verbose: true + # repository-url: https://test.pypi.org/legacy/ + + github-release: + name: >- + Sign the Python 🐍 distribution 📦 with Sigstore + and upload them to GitHub Release + needs: + - publish-to-pypi + runs-on: ubuntu-latest + + permissions: + contents: write # IMPORTANT: mandatory for making GitHub Releases + id-token: write # IMPORTANT: mandatory for sigstore + + steps: + - name: Check if GitHub release already exists + env: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + run: | + if gh release view '${{ github.ref_name }}' --repo '${{ github.repository }}' > /dev/null 2>&1; then + echo "Release already exists for tag '${{ github.ref_name }}'. Skipping release creation." + exit 0 + fi + - name: Download all the dists + uses: actions/download-artifact@v4 + with: + pattern: artemis_materials-* + path: dist + merge-multiple: true + - name: Sign the dists with Sigstore + uses: sigstore/gh-action-sigstore-python@v3.0.0 + with: + inputs: >- + ./dist/*.tar.gz + ./dist/*.whl + - name: Create GitHub Release + env: + GITHUB_TOKEN: ${{ github.token }} + run: >- + gh release create + '${{ github.ref_name }}' + --repo '${{ github.repository }}' + --notes "" + - name: Upload artifact signatures to GitHub Release + env: + GITHUB_TOKEN: ${{ github.token }} + # Upload to GitHub Release using the `gh` CLI. + # `dist/` contains the built packages, and the + # sigstore-produced signatures and certificates. + run: >- + gh release upload + '${{ github.ref_name }}' dist/** + --repo '${{ github.repository }}' + diff --git a/.gitignore b/.gitignore index 2e8f474..a2dd1ee 100644 --- a/.gitignore +++ b/.gitignore @@ -6,4 +6,10 @@ obj/ tests/*/*.txt tests/*/*.out tests/*/DINTERFACES -tests/*/DTERMINATIONS \ No newline at end of file +tests/*/DTERMINATIONS +build/ +dist/ +wheelhouse/ +*.egg-info/ +*.egg +*.pyc \ No newline at end of file diff --git a/.readthedocs.yaml b/.readthedocs.yaml new file mode 100644 index 0000000..95194ca --- /dev/null +++ b/.readthedocs.yaml @@ -0,0 +1,23 @@ +# .readthedocs.yaml +# Read the Docs configuration file +# See https://docs.readthedocs.io/en/stable/config-file/v2.html for details + +# Required +version: 2 + +# Set the OS, Python version and other tools you might need +build: + os: ubuntu-24.04 + tools: + python: "3.13" + +# Build documentation in the "docs/" directory with Sphinx +sphinx: + configuration: docs/source/conf.py + +# Optional but recommended, declare the Python requirements required +# to build your documentation +# See https://docs.readthedocs.io/en/stable/guides/reproducible-builds.html +python: + install: + - requirements: docs/requirements.txt diff --git a/CITATION.cff b/CITATION.cff new file mode 100644 index 0000000..cc22e6a --- /dev/null +++ b/CITATION.cff @@ -0,0 +1,47 @@ +# This CITATION.cff file was generated with cffinit. +# Visit https://bit.ly/cffinit to generate yours today! + +cff-version: 1.2.0 +title: >- + ARTEMIS: Ab Initio Restructuring Tool Enabling Modelling + of Interface Structures +message: >- + If you use this software, please cite it using the + metadata from this file. +type: software +authors: + - given-names: Ned Thaddeus + family-names: Taylor + orcid: 'https://orcid.org/0000-0002-9134-9712' + affiliation: University of Exeter + - given-names: Francis Huw + family-names: Davies + orcid: 'https://orcid.org/0000-0003-0786-2773' + affiliation: University of Exeter + - given-names: Isiah Edward Mikel + family-names: Rudkin + - given-names: Conor Jason + family-names: Price + orcid: 'https://orcid.org/0000-0002-1430-3294' + - given-names: Tsz Hin + family-names: Chan + orcid: 'https://orcid.org/0000-0003-1126-6579' + - given-names: Steven Paul + family-names: Hepplestone + affiliation: University of Exeter + orcid: 'https://orcid.org/0000-0002-2528-1270' +identifiers: + - type: doi + value: 10.1016/j.cpc.2020.107515 + description: Paper detailing the first code release +repository-code: 'https://github.com/ExeQuantCode/ARTEMIS' +abstract: >- + ARTEMIS is a software package for the generation and + modelling of interfaces between materials. +keywords: + - materials science + - interfaces + - material interfaces + - structure generation +license: GPL-3.0 +version: 1.0.2 diff --git a/CMakeLists.txt b/CMakeLists.txt new file mode 100644 index 0000000..616f07e --- /dev/null +++ b/CMakeLists.txt @@ -0,0 +1,350 @@ +cmake_minimum_required(VERSION 3.17.5) + +# define build environments +set( CMAKE_INSTALL_PREFIX "$ENV{HOME}/.local/" + CACHE STRING "Select where to install the library." ) +set(CMAKE_BUILD_DIR ${CMAKE_CURRENT_BINARY_DIR} + CACHE STRING "Select where to build the library." ) +set(MODULE_DIR ${CMAKE_BUILD_DIR}/mod) + +set(SKBUILD_PROJECT_NAME "artemis") + + +# set compiler +set(CMAKE_Fortran_COMPILER gfortran + CACHE STRING "Select Fortran compiler." ) # Change this to your desired compiler +set(CMAKE_C_COMPILER gcc + CACHE STRING "Select C compiler." ) # Change this to your desired compiler +set(CMAKE_Fortran_STANDARD 2018) + +# set the project version +file(READ "fpm.toml" ver) +string(REGEX MATCH "version = \"([0-9]+\\.[0-9]+\\.[0-9]+)(-dev[0-9]+)?\"" _ ${ver}) +set(PROJECT_VERSION ${CMAKE_MATCH_1}) +message(STATUS "Project version: ${PROJECT_VERSION}") + +# set the project name +project(artemis + VERSION ${PROJECT_VERSION} + LANGUAGES C Fortran +) + +# set the library name +set( LIB_NAME ${PROJECT_NAME} ) +set( PROJECT_DESCRIPTION + "Fortran materials lattice matcher" ) +set( PROJECT_URL "https://github.com/ExeQuantCode/artemis" ) +set( CMAKE_CONFIGURATION_TYPES "Release" "Dev" "Debug" + CACHE STRING "List of configurations types." ) +set( CMAKE_BUILD_TYPE "Release" + CACHE STRING "Select which configuration to build." ) + +# set options +option(BUILD_PYTHON "Build the python library" Off) +option(BUILD_EXECUTABLE "Build the Fortran executable" On) +option(REMAKE_F90WRAP "Remake the f90wrap signature file" Off) + +# Define the sources +set(SRC_DIR src) +set(FORTRAN_SRC_DIR ${SRC_DIR}/fortran) +set(LIB_DIR ${FORTRAN_SRC_DIR}/lib) + +# Library source files +set(LIB_FILES + mod_constants.f90 + mod_misc.f90 + mod_io_utils.F90 + mod_help.f90 + mod_misc_maths.f90 + mod_misc_linalg.f90 + mod_geom_utils.f90 + mod_io_utils_extd.F90 + mod_sym.f90 + mod_terminations.f90 + mod_intf_identifier.f90 + mod_plane_matching.f90 + mod_lat_compare.f90 + mod_swapping.f90 + mod_shifting.f90 + mod_cache.f90 +) + +# Main source files +set(SPECIAL_LIB_FILES + mod_misc_types.f90 + mod_geom_rw.f90 + mod_generator.f90 +) + + +foreach(lib ${LIB_FILES}) + list(APPEND PREPENDED_LIB_FILES ${LIB_DIR}/${lib}) +endforeach() +foreach(lib ${SPECIAL_LIB_FILES}) + list(APPEND PREPENDED_LIB_FILES ${LIB_DIR}/${lib}) +endforeach() +message(STATUS "Modified LIB_FILES: ${PREPENDED_LIB_FILES}") + + + +set(SRC_FILES + artemis.f90 +) +foreach(lib ${SPECIAL_LIB_FILES}) + list(APPEND F90WRAP_FORTRAN_SRC_FILES ${CMAKE_CURRENT_LIST_DIR}/${LIB_DIR}/${lib}) +endforeach() +foreach(src ${SRC_FILES}) + list(APPEND F90WRAP_FORTRAN_SRC_FILES ${CMAKE_CURRENT_LIST_DIR}/${FORTRAN_SRC_DIR}/${src}) + list(APPEND PREPENDED_SRC_FILES ${FORTRAN_SRC_DIR}/${src}) +endforeach() + + +set(EXECUTABLE_FILES + mod_tools_infile.f90 + default_infile.f90 + inputs.f90 + aspect.f90 + main.f90 +) +set(APP_DIR app) +foreach(src ${EXECUTABLE_FILES}) + list(APPEND PREPENDED_EXECUTABLE_FILES ${APP_DIR}/${src}) +endforeach() + + +# initialise flags +set(CPPFLAGS "") +set(CFLAGS "") +set(MODULEFLAGS "") +set(MPFLAGS "") +set(WARNFLAGS "") +set(DEVFLAGS "") +set(DEBUGFLAGS "") +set(MEMFLAGS "") +set(OPTIMFLAGS "") +set(FASTFLAGS "") + +# set flags based on compiler +if (CMAKE_Fortran_COMPILER MATCHES ".*gfortran.*" OR CMAKE_Fortran_COMPILER MATCHES ".*gcc.*") + message(STATUS "Using gfortran compiler") + set(PPFLAGS -cpp) + set(MPFLAGS -fopenmp -lgomp -floop-parallelize-all -ftree-parallelize-loops=32) + set(WARNFLAGS -Wall) + set(DEVFLAGS -g -fbacktrace -fcheck=all -fbounds-check -Og) + set(DEBUGFLAGS -fbounds-check) + set(MEMFLAGS -mcmodel=large) + set(OPTIMFLAGS -O3 -march=native) + set(FASTFLAGS -Ofast -march=native) + set(PYTHONFLAGS -c -O3 -fPIC) +elseif (CMAKE_Fortran_COMPILER MATCHES ".*nag.*") + message(STATUS "Using nag compiler") + set(PPFLAGS -f2018 -fpp) + set(MPFLAGS -openmp) + set(WARNFLAGS -Wall) + set(DEVFLAGS -g -mtrace -C=all -colour -O0) + set(DEBUGFLAGS -C=array) + set(MEMFLAGS -mcmodel=large) + set(OPTIMFLAGS -O3) + set(FASTFLAGS -Ofast) +elseif (CMAKE_Fortran_COMPILER MATCHES ".*ifort.*" OR CMAKE_Fortran_COMPILER MATCHES ".*ifx.*") + message(STATUS "Using intel compiler") + set(PPFLAGS -fpp) + set(MPFLAGS -qopenmp) + set(WARNFLAGS -warn all) + set(DEVFLAGS -check all -warn) + set(DEBUGFLAGS -check all -fpe0 -warn -tracekback -debug extended) + set(MEMFLAGS -mcmodel=large) + set(OPTIMFLAGS -O3) + set(FASTFLAGS -Ofast) +else() + # Code for other Fortran compilers + message(STATUS "Using a different Fortran compiler") +endif() + + + +set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} ${PPFLAGS}") + + +# create the library +add_library(${PROJECT_NAME} STATIC ${PREPENDED_LIB_FILES} ${PREPENDED_SRC_FILES}) +set_target_properties(${PROJECT_NAME} PROPERTIES Fortran_MODULE_DIRECTORY ${MODULE_DIR}) +target_link_libraries(${PROJECT_NAME} PUBLIC) + +# replace ".f90" with ".mod" +string(REGEX REPLACE "\\.[^.]*$" ".mod" MODULE_FILES "${SRC_FILES}") + +set(ETC_MODULE_FILES "") +# Loop through each Fortran file +foreach(FILE ${PREPENDED_LIB_FILES}) + # Read the content of the Fortran file + file(READ "${FILE}" FILE_CONTENTS) + + # Use a regular expression to extract the module name + string(REGEX MATCH "^module[ \t]+([a-zA-Z0-9_]+)" MATCH "${FILE_CONTENTS}") + + # If a match is found, extract the module name (the first capture group) + if(MATCH) + string(REGEX REPLACE "module[ \t]+([a-zA-Z0-9_]+)" "\\1" MODULE_NAME "${MATCH}") + + # Append the module name with .mod to the list + list(APPEND ETC_MODULE_FILES "${MODULE_DIR}/${MODULE_NAME}.mod") + endif() +endforeach() + +# installation +install(FILES ${MODULE_DIR}/${MODULE_FILES} DESTINATION ${SKBUILD_PROJECT_NAME}/include) +install(FILES ${ETC_MODULE_FILES} DESTINATION ${SKBUILD_PROJECT_NAME}/etc) +install(TARGETS ${PROJECT_NAME} DESTINATION ${SKBUILD_PROJECT_NAME}/lib) +set_target_properties(${PROJECT_NAME} PROPERTIES VERSION ${PROJECT_VERSION}) + +# set compile options based on different build configurations +target_compile_options(${PROJECT_NAME} PUBLIC "$<$:${OPTIMFLAGS}>") +# target_compile_options(${PROJECT_NAME} PUBLIC "$<$:${MPFLAGS}>") +target_compile_options(${PROJECT_NAME} PUBLIC "$<$:${PYTHONFLAGS}>") + +target_compile_options(${PROJECT_NAME} PUBLIC "$<$:${DEVFLAGS}>") + +target_compile_options(${PROJECT_NAME} PUBLIC "$<$:${DEBUGFLAGS}>") +target_compile_options(${PROJECT_NAME} PUBLIC "$<$:${WARNFLAGS}>") +# target_compile_options(${PROJECT_NAME} PUBLIC "$<$:${MPFLAGS}>") +target_compile_options(${PROJECT_NAME} PUBLIC "$<$:${PYTHONFLAGS}>") + +if (BUILD_EXECUTABLE) + add_executable(${PROJECT_NAME}_executable ${PREPENDED_EXECUTABLE_FILES}) + target_link_libraries(${PROJECT_NAME}_executable PRIVATE ${PROJECT_NAME}) + install(TARGETS ${PROJECT_NAME}_executable DESTINATION ${SKBUILD_PROJECT_NAME}/bin) + set_target_properties(${PROJECT_NAME}_executable PROPERTIES Fortran_MODULE_DIRECTORY ${MODULE_DIR}) + + target_compile_options(${PROJECT_NAME}_executable PUBLIC "$<$:${OPTIMFLAGS}>") + # target_compile_options(${PROJECT_NAME}_executable PUBLIC "$<$:${MPFLAGS}>") + target_compile_options(${PROJECT_NAME}_executable PUBLIC "$<$:${PYTHONFLAGS}>") + + target_compile_options(${PROJECT_NAME}_executable PUBLIC "$<$:${DEVFLAGS}>") + + target_compile_options(${PROJECT_NAME}_executable PUBLIC "$<$:${DEBUGFLAGS}>") + target_compile_options(${PROJECT_NAME}_executable PUBLIC "$<$:${WARNFLAGS}>") + # target_compile_options(${PROJECT_NAME}_executable PUBLIC "$<$:${MPFLAGS}>") + target_compile_options(${PROJECT_NAME}_executable PUBLIC "$<$:${PYTHONFLAGS}>") + + set_target_properties(${PROJECT_NAME}_executable PROPERTIES VERSION ${PROJECT_VERSION}) +endif() + + + +if (BUILD_PYTHON) + + # # Get the directory where object files are generated + get_target_property(OBJECTS ${PROJECT_NAME} EXTERNAL_OBJECT) + # Print the object files directory + set(OBJECTS_DIR ${CMAKE_BUILD_DIR}/CMakeFiles/${PROJECT_NAME}.dir) + message(STATUS "Object files directory for ${PROJECT_NAME}: ${OBJECTS_DIR}") + + # Include f90wrap + find_package(Python COMPONENTS Interpreter Development.Module NumPy REQUIRED) + if(NOT DEFINED PYTHON_EXECUTABLE) + set(PYTHON_EXECUTABLE ${Python_EXECUTABLE}) + endif() + + # Grab the variables from a local Python installation F2PY headers + execute_process( + COMMAND "${Python_EXECUTABLE}" -c + "import numpy.f2py; print(numpy.f2py.get_include())" + OUTPUT_VARIABLE F2PY_INCLUDE_DIR + OUTPUT_STRIP_TRAILING_WHITESPACE) + + add_library(fortranobject OBJECT "${F2PY_INCLUDE_DIR}/fortranobject.c") + target_link_libraries(fortranobject PUBLIC Python::NumPy) + target_include_directories(fortranobject PUBLIC "${F2PY_INCLUDE_DIR}") + set_property(TARGET fortranobject PROPERTY POSITION_INDEPENDENT_CODE ON) + + set (F90WRAP_EXECUTABLE ${PYTHON_EXECUTABLE} -m f90wrap) + set (F2PY_EXECUTABLE ${PYTHON_EXECUTABLE} -m f90wrap --f2py-f90wrap) + + # Run Python command to get the extension suffix + execute_process( + COMMAND ${Python_EXECUTABLE} -c "import sysconfig; print(sysconfig.get_config_var('EXT_SUFFIX'))" + RESULT_VARIABLE result + OUTPUT_VARIABLE PYTHON_EXTENSION_MODULE_SUFFIX + OUTPUT_STRIP_TRAILING_WHITESPACE + ) + + # Check if the suffix was retrieved successfully + if (result EQUAL 0) + message(STATUS "Python extension module suffix: ${PYTHON_EXTENSION_MODULE_SUFFIX}") + else() + message(FATAL_ERROR "Failed to retrieve Python extension module suffix") + endif() + set(F2PY_OUTPUT_FILE ${CMAKE_BUILD_DIR}/artemis/_${PROJECT_NAME}${PYTHON_EXTENSION_MODULE_SUFFIX}) + + # Generate f90wrap signature file + set(F90WRAP_FILE + ${CMAKE_CURRENT_LIST_DIR}/src/wrapper/f90wrap_mod_generator.f90 + ${CMAKE_CURRENT_LIST_DIR}/src/wrapper/f90wrap_mod_misc_types.f90 + ${CMAKE_CURRENT_LIST_DIR}/src/wrapper/f90wrap_mod_geom_rw.f90 + ${CMAKE_CURRENT_LIST_DIR}/src/wrapper/f90wrap_artemis.f90 + ) + if (REMAKE_F90WRAP) + set(KIND_MAP ${CMAKE_SOURCE_DIR}/kind_map) + set(F90WRAP_REMAKE_FILE ${CMAKE_BUILD_DIR}/f90wrap_${PROJECT_NAME}.f90) + add_custom_command( + OUTPUT ${F90WRAP_REMAKE_FILE} + COMMAND ${F90WRAP_EXECUTABLE} + --default-to-inout + -m ${PROJECT_NAME} + -k ${KIND_MAP} + ${F90WRAP_FORTRAN_SRC_FILES} + --only artemis_generator_type basis_type struc_data_type: + DEPENDS ${F90WRAP_FORTRAN_SRC_FILES} + WORKING_DIRECTORY ${CMAKE_BUILD_DIR} + COMMENT "Generating f90wrap signature file" + VERBATIM + ) + endif() + + # Copy f90wrap edited files from edited_autogen_files to ${CMAKE_BUILD_DIR} + add_custom_command( + OUTPUT ${CMAKE_BUILD_DIR}/artemis/python_copied + COMMAND ${CMAKE_COMMAND} -E copy_directory ${CMAKE_CURRENT_LIST_DIR}/${SRC_DIR}/artemis ${CMAKE_BUILD_DIR}/artemis + COMMENT "Copying artemis python files" + ) + + # If parallel build, need to add the parallel flag + if (CMAKE_BUILD_TYPE MATCHES "Release*" OR CMAKE_BUILD_TYPE MATCHES "Parallel*" OR CMAKE_BUILD_TYPE MATCHES "Debug") + set(GOMPFLAGS "-lgomp") + else() + set(GOMPFLAGS "") + endif() + + # Create a Python module using f2py + add_custom_command( + OUTPUT ${F2PY_OUTPUT_FILE} + COMMAND CC="${CMAKE_C_COMPILER}" LDFLAGS="-L${CMAKE_BUILD_DIR}" LIBS="-lartemis" ${F2PY_EXECUTABLE} + -c + -m _${PROJECT_NAME} + -I${MODULE_DIR} + --f90flags="${PPFLAGS}" + ${GOMPFLAGS} + --backend meson + ${F90WRAP_FILE} + -L${CMAKE_BUILD_DIR} + -lartemis + # --build-dir ${CMAKE_BUILD_DIR}/Dmeson + DEPENDS ${F90WRAP_FILE} ${CMAKE_BUILD_DIR}/artemis/python_copied ${PROJECT_NAME} + WORKING_DIRECTORY ${CMAKE_BUILD_DIR}/artemis + COMMENT "Creating Python module using f2py" + ) + + # Define output files + set(PY_MODULE ${CMAKE_BUILD_DIR}/artemis/${PROJECT_NAME}.py ${CMAKE_BUILD_DIR}/artemis/__init__.py) + + # Create a custom target for the Python module + add_custom_target(python_module ALL + DEPENDS ${F90WRAP_REMAKE_FILE} ${F2PY_OUTPUT_FILE} + ) + + # Installation instructions + install(FILES ${PY_MODULE} DESTINATION ${SKBUILD_PROJECT_NAME}) + install(FILES ${F2PY_OUTPUT_FILE} DESTINATION ${SKBUILD_PROJECT_NAME}) + +endif() diff --git a/CODE_OF_CONDUCT.md b/CODE_OF_CONDUCT.md new file mode 100644 index 0000000..79a5f06 --- /dev/null +++ b/CODE_OF_CONDUCT.md @@ -0,0 +1,70 @@ +# Code of Conduct - ARTEMIS + +## Our Pledge + +In the interest of fostering an open and welcoming environment, we as +contributors and maintainers pledge to make participation in our project and +our community a harassment-free experience for everyone, regardless of age, body +size, disability, ethnicity, sex characteristics, gender identity and expression, +level of experience, education, socio-economic status, nationality, personal +appearance, race, religion, or sexual identity and orientation. + +## Our Standards + +Examples of behavior that contributes to a positive environment for our +community include: + +* Demonstrating empathy and kindness toward other people +* Being respectful of differing opinions, viewpoints, and experiences +* Giving and gracefully accepting constructive feedback +* Accepting responsibility and apologising to those affected by our mistakes, +and learning from the experience +* Focusing on what is best not just for us as individuals, but for the +overall community + +Examples of unacceptable behavior include: + +* The use of sexualised language or imagery, and sexual attention or +advances +* Trolling, insulting or derogatory comments, and personal or political attacks +* Public or private harassment +* Publishing others' private information, such as a physical or email +address, without their explicit permission +* Other conduct which could reasonably be considered inappropriate in a +professional setting + +## Our Responsibilities + +Project maintainers are responsible for clarifying and enforcing our standards of +acceptable behavior and will take appropriate and fair corrective action in +response to any instances of unacceptable behavior. + +Project maintainers have the right and responsibility to remove, edit, or reject +comments, commits, code, wiki edits, issues, and other contributions that are +not aligned to this Code of Conduct, or to ban +temporarily or permanently any contributor for other behaviors that they deem +inappropriate, threatening, offensive, or harmful. + +## Scope + +This Code of Conduct applies within all community spaces, and also applies when +an individual is officially representing the community in public spaces. +Examples of representing our community include using an official e-mail address, +posting via an official social media account, or acting as an appointed +representative at an online or offline event. + +## Enforcement + +Instances of abusive, harassing, or otherwise unacceptable behavior may be +reported to the community leaders responsible for enforcement at . +All complaints will be reviewed and investigated promptly and fairly. + +All community leaders are obligated to respect the privacy and security of the +reporter of any incident. + +## Attribution + +This Code of Conduct is adapted from the [Contributor Covenant](https://contributor-covenant.org/), version +[1.4](https://www.contributor-covenant.org/version/1/4/code-of-conduct/code_of_conduct.md) and +[2.0](https://www.contributor-covenant.org/version/2/0/code_of_conduct/code_of_conduct.md), +and was generated by [contributing-gen](https://github.com/bttger/contributing-gen). diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 index 0000000..2a3b146 --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,117 @@ +# Contributing Guidelines + +Thank you for considering contributing to the ARTEMIS project! We appreciate your time and effort. To ensure a smooth collaboration, please follow the guidelines provided below. + +Please first discuss potential changes you wish to make to the project via issue (preferably), or email. + +> And if you like the project, but just don't have time to contribute, that's fine. There are other easy ways to support the project and show your appreciation, which we would also be very happy about: +> - Star the project +> - Mention it on social media platforms +> - Refer this project in your project's readme +> - Mention the project at local meetups and tell your friends/colleagues + + + +## Table of Contents +- [Code of Conduct](#code-of-conduct) +- [I Have a Question](#i-have-a-question) +- [I Want to Contribute](#i-want-to-contribute) +- [Reporting Bugs](#reporting-bugs) +- [Suggesting Enhancements](#suggesting-enhancements) +- [Code Style](#code-style) +- [Testing](#testing) +- [Documentation](#documentation) +- [Contact](#contact) +- [License](#license) + + +## Code of Conduct + +This project and everyone participating in it is governed by the +[ARTEMIS Code of Conduct](CODE_OF_CONDUCT.md). +By participating, you are expected to uphold this code. +Please report unacceptable behavior to the [ARTEMIS developers](mailto:support@artemis-materials.co.uk?subject=ARTEMIS%20-%behaviour). + +## I Have a Question + +> If you want to ask a question, we assume that you have read the available [Documentation](README.md). + +Before you ask a question, it is best to search for existing [Issues](https://github.com/ExeQuantCode/ARTEMIS/issues) that might help you. +In case you have found a suitable issue and still need clarification, you can write your question in this issue. It is also advisable to search the internet for answers first. + +If you then still feel the need to ask a question and need clarification, we recommend the following: + +- Open an [Issue](https://github.com/ExeQuantCode/ARTEMIS/issues/new). +- Provide as much context as you can about what you're running into. +- Provide project and platform versions (python, fortran, pip), depending on what seems relevant. + +We will then take care of the issue as soon as possible. + +## I Want To Contribute + +> ### Legal Notice +> When contributing to this project, you must agree that you have authored 100% of the content, that you have the necessary rights to the content and that the content you contribute may be provided under the project license. + +### Reporting Bugs +If you encounter any issues or have suggestions for improvement, please open an [Issue](https://github.com/ExeQuantCode/ARTEMIS/issues/new) on the repository's issue tracker. + +When reporting, please provide as much context as possible and describe the reproduction steps that someone else can follow to recreate the issue on their own. +This usually includes your code. +For good bug reports you should isolate the problem and create a reduced test case. + + + +### Suggesting Enhancements + +This section guides you through submitting an enhancement suggestion for ARTEMIS, **including completely new features and minor improvements to existing functionality**. +Following these guidelines will help maintainers and the community to understand your suggestion and find related suggestions. + + +#### Before Submitting an Enhancement + +- Make sure that you are using the latest version. +- Read the compilable documentation carefully and find out if the functionality is already covered. +- Perform a [search](https://github.com/ExeQuantCode/ARTEMIS/issues) to see if the enhancement has already been suggested. If it has, add a comment to the existing issue instead of opening a new one. +- Find out whether your idea fits with the scope and aims of the project. It's up to you to make a strong case to convince the project's developers of the merits of this feature. Keep in mind that we want features that will be useful to the majority of our users and not just a small subset. If you're just targeting a minority of users, consider writing an add-on/plugin library. + + +### Contributing Code + +This guide provides the recommended route to contributing to ARTEMIS: + +1. Fork the repository. +2. Clone the forked repository to your local machine. +3. Create a new branch for your changes. +4. Make your changes and commit them. +5. Push the changes to your forked repository. +6. Open a pull request to the main repository. + +When submitting your contributions, please ensure the following: +- Provide a clear and descriptive title for your pull request. +- Include a detailed description of the changes made. +- Reference any related issues or pull requests, if applicable. +- Write unit tests for your contributions +- Ensure all existing tests pass before submitting your changes. +- Update the documentation to reflect your changes, if necessary (i.e. through FORD style commenting). +- Provide examples and usage instructions, if applicable. + +Follow the [Code Style](#code-style) when contributing code to this project to ensure compatibility and a uniform format to the project. + + +### Code Style +- Follow the code style and conventions set out in the [RAFFLE codebase](https://github.com/ExeQuantCode/RAFFLE). Moving forward, the [ARTEMIS codebase](https://github.com/ExeQuantCode/ARTEMIS) will be adopting this format and, as such, will transition all old commenting, documentation, and general code style to this form (this is likely to be a slow process). +- Use meaningful variable and function names. +- Write clear and concise comments. For the Fortran library, use comments compatible with the [FORD Fortran Documenter](https://forddocs.readthedocs.io/en/stable/). The Fortran library does not yet support the FORD documenter, but the plan is to align it with the RAFFLE codebase and maintain the same level of documenter support. For the Python wrapper, use comments compatible with [pandoc](https://pandoc.org). + + + +## Contact +If you have any questions or need further assistance, feel free to contact the [ARTEMIS developers](mailto:support@artemis-materials.co.uk?subject=ARTEMIS%20-%query). + +## License +This project is licensed under the [GPL-3.0 License](LICENSE). + + +## Attribution +This guide is based on the **contributing-gen** and has been copied from the [graphstruc](https://github.com/nedtaylor/graphstruc) repository, with permission from the creator (Ned Taylor). +[Make your own](https://github.com/bttger/contributing-gen)! diff --git a/LICENCE b/LICENCE deleted file mode 100644 index 157abb7..0000000 --- a/LICENCE +++ /dev/null @@ -1,2 +0,0 @@ -This work is licensed under a Creative Commons Attribution-NonCommercial 3.0 Unported (CC BY-NC 3.0) License. -https://creativecommons.org/licenses/by-nc/3.0/ \ No newline at end of file diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..f288702 --- /dev/null +++ b/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/Makefile b/Makefile deleted file mode 100644 index e86e47b..0000000 --- a/Makefile +++ /dev/null @@ -1,107 +0,0 @@ -########################################## -# CODE DIRECTORIES AND FILES -########################################## -mkfile_path := $(abspath $(firstword $(MAKEFILE_LIST))) -mkfile_dir := $(dir $(mkfile_path)) -BIN_DIR := ./bin -SRC_DIR := ./src -LIB_DIR := ./lib -BUILD_DIR = ./obj -LIBS := mod_constants.f90 \ - mod_misc.f90 \ - mod_misc_maths.f90 \ - mod_misc_linalg.f90 \ - mod_tools_infile.f90 \ - mod_rw_geom.f90 \ - mod_edit_geom.f90 \ - mod_sym.f90 -OBJS := $(addprefix $(LIB_DIR)/,$(LIBS)) -#$(info VAR is $(OBJS)) -SRCS := io.F90 \ - aspect.f90 \ - mod_help.f90 \ - mod_intf_identifier.f90 \ - mod_plane_matching.f90 \ - mod_lat_compare.f90 \ - mod_swapping.f90 \ - mod_shifting.f90 \ - default_infile.f90 \ - inputs.f90 \ - interfaces.f90 \ - main.f90 -SRCS := $(OBJS) $(SRCS) -OBJS := $(addprefix $(SRC_DIR)/,$(SRCS)) - - -########################################## -# COMPILER CHOICE SECTION -########################################## -FFLAGS = -O2 -#PPFLAGS = -cpp -FC=gfortran -ifeq ($(FC),ifort) - MPIFLAG = -qopenmp - MODULEFLAG = -module - DEVFLAGS = -check all -warn #all - DEBUGFLAGS = -check all -fpe0 -warn -tracekback -debug extended -else - MPIFLAG = -fopenmp - MODULEFLAG = -J - DEVFLAGS = -g -fbacktrace -fcheck=all - DEBUGFLAGS = -fbounds-check -Wall -Wno-maybe-uninitialized -endif - - -########################################## -# LAPACK SECTION -########################################## -MKLROOT?="/usr/local/intel/parallel_studio_xe_2017/compilers_and_libraries_2017/linux/mkl/lib/intel64_lin" -LLAPACK = $(MKLROOT)/libmkl_lapack95_lp64.a \ - -Wl,--start-group \ - $(MKLROOT)/libmkl_intel_lp64.a \ - $(MKLROOT)/libmkl_sequential.a \ - $(MKLROOT)/libmkl_core.a \ - -Wl,--end-group \ - -lpthread - -#$(MKLROOT)/libmkl_scalapack_lp64.a \ -#$(MKLROOT)/libmkl_solver_lp64_sequential.a \ - - -########################################## -# COMPILATION SECTION -########################################## -INSTALL_DIR?=$(HOME)/bin -ARTEMIS = artemis -programs = $(BIN_DIR)/$(ARTEMIS) - -.PHONY: all debug install uninstall dev mpi clean - -all: $(programs) - -$(BIN_DIR): - mkdir -p $@ - -$(BUILD_DIR): - mkdir -p $@ - -$(BIN_DIR)/$(ARTEMIS): $(OBJS) | $(BIN_DIR) $(BUILD_DIR) - $(FC) $(MODULEFLAG) $(BUILD_DIR) $(OBJS) -o $@ - -install: $(OBJS) | $(INSTALL_DIR) $(BUILD_DIR) - $(FC) $(MODULEFLAG) $(BUILD_DIR) $(OBJS) -o $(INSTALL_DIR)/$(ARTEMIS) - -debug: $(OBJS) | $(BIN_DIR) $(BUILD_DIR) - $(FC) $(DEBUGFLAGS) $(MODULEFLAG) $(BUILD_DIR) $(OBJS) -o $(programs) - -dev: $(OBJS) | $(BIN_DIR) $(BUILD_DIR) - $(FC) $(DEVFLAGS) $(MODULEFLAG) $(BUILD_DIR) $(OBJS) -o $(programs) - -mpi: $(OBJS) | $(BIN_DIR) $(BUILD_DIR) - $(FC) $(MPIFLAG) $(MODULEFLAG) $(BUILD_DIR) $(OBJS) -o $(programs) - -clean: $(BUILD_DIR) $(BIN_DIR) - rm -r $(BUILD_DIR)/ $(BIN_DIR)/ - -uninstall: $(INSTALL_DIR)/$(ARTEMIS) - rm $(INSTALL_DIR)/$(ARTEMIS) diff --git a/README.md b/README.md index cf28073..fa353c3 100644 --- a/README.md +++ b/README.md @@ -2,10 +2,13 @@

-[![License: CC BY-NC 3.0](https://img.shields.io/badge/License-CC_BY--NC_3.0-lightgrey.svg)](https://creativecommons.org/licenses/by-nc/3.0/ "View CC BY-NC 3.0 license") +[![GPLv3 workflow](https://img.shields.io/badge/License-GPLv3-yellow.svg)](https://www.gnu.org/licenses/gpl-3.0.en.html "View GPLv3 license") [![Latest Release](https://img.shields.io/github/v/release/ExeQuantCode/ARTEMIS?sort=semver)](https://github.com/ExeQuantCode/ARTEMIS/releases "View on GitHub") [![Paper](https://img.shields.io/badge/Paper-Comp_Phys_Comms-orange.svg)](https://doi.org/10.1016/j.cpc.2020.107515) -[![GCC compatibility](https://img.shields.io/badge/gcc-14.1.0-green)](https://gcc.gnu.org/gcc-14/ "View GCC") +[![Documentation Status](https://readthedocs.org/projects/artemis-materials/badge/?version=latest)](https://artemis-materials.readthedocs.io/en/latest/?badge=latest "ARTEMIS ReadTheDocs") +[![FPM](https://img.shields.io/badge/fpm-0.11.0-purple)](https://github.com/fortran-lang/fpm "View Fortran Package Manager") +[![CMAKE](https://img.shields.io/badge/cmake-3.27.7-red)](https://github.com/Kitware/CMake/releases/tag/v3.27.7 "View cmake") +[![GCC compatibility](https://img.shields.io/badge/gcc-14.2.0-green)](https://gcc.gnu.org/gcc-14/ "View GCC") Ab Initio Restructuring Tool Enabling Modelling of Interface Structures @@ -29,140 +32,229 @@ All information has been ported over where possible. ARTEMIS is a software package for the generation and modelling of interfaces between materials. -ARTEMIS is distributed with the following directories: +ARTEMIS is both a Fortran and a Python library, with the option of a Fortran executable. +The code relies on recent Fortran features, so has no backwards compatibility with Fortran95. - docs/ Documentation - src/ Source code - tools/ Extra shell script tools - examples/ Example ARTEMIS files -After ARTEMIS is compiled, the following directories may also exist: +## Documentation - bin/ Contains binary executables - obj/ Contains object (built/indermetiate) files, which are compiled binary files that haven't been linked yet -For further information please see the User manual (docs/manual.pdf) +> **_NOTE_:** +> The Read*the*Docs is still under development. +> More guides will be added in the coming weeks and months. +Tutorials and documentation will be provided on the [docs](http://artemis-materials.readthedocs.io/) website. +The methodology is detailed in the [paper](https://doi.org/10.1016/j.cpc.2020.107515). +Refer to the [API Documentation section](#api-documentation) later in this document to see how to access the API-specific documentation. -Setup ------ -Run the following command in the directory containing the Makefile: -make +The Fortran executable/app currently has the most extensive documentation. +This can be found in two forms: +1. [The PDF manual](docs/manual.pdf) +2. The executable help function (`--help` and `--search` flags) -This should create a bin directory, in which the executable -'artemis' can be found. This directory should be found in the -DARTEMIS directory. +## Requirements +- Fortran compiler supporting Fortran 2018 standard or later +- fpm or CMake (fpm works only for Fortran installation) + +Python-specific installation: + +- Python 3.11 or later (might work on earlier, have not tested) +- NumPy.f2py +- f90wrap +- cython +- scikit-build-core +- meson +- make or ninja +- CMake +- ASE + +The library bas been developed and tested using the following Fortran compilers: +- gfortran -- gcc 11.4.0 +- gfortran -- gcc 13.2.0 +- gfortran -- gcc 14.1.0 +- gfortran -- gcc 14.2.0 + +The library is known to not currently work with the intel Fortran compilers. + +## Installation + +For the Python library, the easiest method of installation is to install it directly from pip: + +``` +pip install artemis-materials +``` + +Once this is done, ARTEMIS is ready to be used. + +Alternatively, to download development versions or, if, for some reason, the pip method does not work, then ARTEMIS can be installed from the source. +To do so, the source must be obtained from the git repository. +Use the following commands to get started: +``` + git clone https://github.com/ExeQuantCode/artemis.git + cd artemis +``` + +Depending on what language will be used in, installation will vary from this point. + +### Python + +For Python, the easiest installation is through pip: +``` +pip install . +``` + +Another option is installing it through cmake, which involves: +``` +mkdir build +cd build +cmake .. +make install +``` + +Then, the path to the install directory (`${HOME}/.local/artemis`) needs to be added to the include path. NOTE: this method requires that the user manually installs the `ase`, `numpy` and `f90wrap` modules for Python. + +### Fortran + +For Fortran, either fpm or cmake are required. + +#### fpm + +fpm installation is as follows: + +``` +fpm build --profile release +``` + +This will install both the Fortran library and the Fortran application for ARTEMIS. +The library can then be called from other fpm-built Fortran programs through normal means (usually referencing the location of ARTEMIS in the program's own `fpm.toml` file). +The application can be run using +``` +fpm run +``` + +#### cmake + +cmake installation is as follows: +``` +mkdir build +cd build +cmake [-DBUILD_PYTHON=Off] .. +make install +``` +The optional filed (dentoted with `[...]`) can be used to turn off installation of the Python library. +This will build the library in the build/ directory. +All library files will then be found in: +``` +${HOME}/.local/artemis +``` +Inside this directory, the following files will be generated: +``` +include/artemis.mod +lib/libartemis.a +``` How-to ------ -ARTEMIS mainly works off of an input file, but can also perform some -actions via flags. - +Until recently, ARTEMIS has existed solely as a Fortran executable. +This version of the code is currently best documented, but this will change in the near future as the Python library is tested more. To get an example input file, run the following command: +``` artemis -d example.in +``` -This will generate the file 'example.in', with the structure of the +This will generate the file `example.in`, with the structure of the ARTEMIS input file. -To get descriptions of the tags within the input file, run either command: -artemis --help [TAGNAME] -artemis --search - +To get descriptions of the tags within the input file, run either command: -Further documentation on the workings of ARTEMIS can be found in the docs/ -directory or on the wiki (linked below) +``` +artemis --help [all|] +artemis --search +``` Websites -------- -Webpage: http:/www.artemis-materials.co.uk/ -Wiki: http://www.artemis-materials.co.uk/HRG +Group webpage: http://www.artemis-materials.co.uk +Group wiki: http://www.artemis-materials.co.uk/HRG -Contact -------- -Please log issues, bug-reports, and feature requests on the issue tracker for this repository: https://github.com/ExeQuantCode/ARTEMIS/issues +Guide and documentation: https://artemis-materials.readthedocs.io/en/latest/ -For any serious or private concerns, please use the following email address: -support@artemis-materials.co.uk +API documentation +----------------- +> **_NOTE_:** +> API documentation is not yet set up. +> It is planned to be implemented in an upcoming release to work alongside the Read*the*Docs and Python library. -Developers ------------- --Ned Thaddues Taylor --Francis Huw Davies --Isiah Edward Mikel Rudkin --Steven Paul Hepplestone + -Advisors +Contributing ------------ --Elizabeth L. Martin + +Please note that this project adheres to the [Contributing Guide](CONTRIBUTING.md). +If you want to contribute to this project, please first read through the guide. +If you have any questions, bug reports, or feature requests, please either discuss then in [issues](https://github.com/ExeQuantCode/artemis/issues). + +For any serious or private concerns, please use the following email address: +support@artemis-materials.co.uk License ------------ -This work is licensed under a Creative Commons Attribution-NonCommercial 3.0 Unported (CC BY-NC 3.0) License. -https://creativecommons.org/licenses/by-nc/3.0/ +This work is licensed under a [GPL v3 license]([https://opensource.org/license/mit/](https://www.gnu.org/licenses/gpl-3.0.en.html)). +Developers +------------ +- Ned Thaddues Taylor +- Francis Huw Davies +- Isiah Edward Mikel Rudkin +- Steven Paul Hepplestone -Source file descriptions +Contributers ------------ -src/main.f90 - main file that calls the functions and determines the task of the job -src/inputs.f90 - handles input file and assigned default values to parameters -src/interfaces.f90 - task 1 ARTEMIS job. Calls subroutines to generate interfaces -src/aspect.f90 - task 0 ARTEMIS job. Calls subroutines to edit structure -src/io.F90 - error handling file, help, search and startup printing -src/mod_help.f90 - descriptions of all input tags -src/default_infile.f90 - prints default/example input file of ARTEMIS -src/mod_shifting.f90 - identifies and generates sets of interface shifts -src/mod_swapping.f90 - generates sets of swaps (intermixing) -src/mod_intf_identifier.f90 - identifies interface axis and location for pregen interface -src/mod_lat_compare.f90 - performs lattice matching over a set of Miller planes -src/mod_plane_matching.f90 - performs lattice matching over a single Miller plane - -src/lib/mod_constants.f90 - a set of global constants used in this code -src/lib/mod_misc.f90 - miscellaneous functions and subroutines -src/lib/mod_misc_maths.f90 - maths functions and subroutines -src/lib/mod_misc_linalg.f90 - linear algebra functions and subroutines -src/lib/mod_rw_geom.f90 - read and write structure (geometry) files -src/lib/mod_edit_geom.f90 - tools to edit lattice and basis (geometry editing) -src/lib/mod_sym.f90 - tools to apply and determine symmetries between bases -src/lib/mod_tools_infile.f90 - tools to read input files - - - -Other files +- Conor Jason Price +- Tsz Hin Chan +- Joe Pitfield +- Edward Allery Baker +- Shane Graham Davies + +Advisors ------------ -README.md - a readme file with a brief description of the code and files -Makefile - the makefile used for compiling the code -LICENSE - license of ARTEMIS code -CHANGE.LOG - changelog for ARTEMIS -artemis.ascii - ARTEMIS logo in ascii form -artemis_logo.pdf - ARTEMIS logo -docs/manual.pdf - pdf of ARTEMIS manual/user guide -docs/manual.tex - tex file of ARTEMIS manual -tools/compress.sh - script to compress ARTEMIS directory -examples/generate_interface/param.in - example input file -examples/generate_interface/POSCAR_Si - silicon 8 atom unit cell -examples/generate_interface/POSCAR_Ge - germanium 8 atom unit cell -examples/generate_interface/DINTERFACES - directory containing example output interface structures -examples/pregenerated_interface/param.in - example input file -examples/pregenerated_interface/POSCAR - CaCu3Ti4O12|CuO interface structure -examples/pregenerated_interface/DINTERFACES - directory containing example output interface structures -examples/identify_terminations/param.in - example input file -examples/identify_terminations/POSCAR - silicon 2 atom primitive cell -examples/identify_terminations/DTERMINATIONS - directory containing example output slab structures +- Elizabeth L. Martin + + + +## References + +If you use this code, please cite our paper: +```text +@article{Taylor2020ARTEMISAbInitio, + title = {ARTEMIS: Ab initio restructuring tool enabling the modelling of interface structures}, + volume = {257}, + ISSN = {0010-4655}, + url = {http://dx.doi.org/10.1016/j.cpc.2020.107515}, + DOI = {10.1016/j.cpc.2020.107515}, + journal = {Computer Physics Communications}, + publisher = {Elsevier BV}, + author = {Taylor, Ned Thaddeus and Davies, Francis Huw and Rudkin, Isiah Edward Mikel and Price, Conor Jason and Chan, Tsz Hin and Hepplestone, Steven Paul}, + year = {2020}, + month = dec, + pages = {107515} +} +``` + +This README has been copied from the [RAFFLE repository](https://github.com/ExeQuantCode/RAFFLE), with permission from the creator (Ned Taylor). \ No newline at end of file diff --git a/src/aspect.f90 b/app/aspect.f90 similarity index 75% rename from src/aspect.f90 rename to app/aspect.f90 index 0602de3..7069d27 100644 --- a/src/aspect.f90 +++ b/app/aspect.f90 @@ -5,9 +5,9 @@ !!! Code part of the ARTEMIS group !!!############################################################################# module aspect - use io - use rw_geom, only: bas_type,clone_bas - use edit_geom + use artemis__io_utils, only: err_abort + use artemis__geom_rw, only: basis_type + use artemis__geom_utils implicit none private @@ -25,9 +25,9 @@ module aspect integer :: nedits integer, dimension(nopt_edits) :: list !! lists order of edits to perform integer, dimension(nopt_edits) :: axis - double precision, dimension(nopt_edits) :: val !BOUNDS FOR EACH? - double precision, dimension(nopt_edits,2) :: bounds !BOUNDS FOR EACH? - double precision, dimension(3,3) :: tfmat + real(real32), dimension(nopt_edits) :: val !BOUNDS FOR EACH? + real(real32), dimension(nopt_edits,2) :: bounds !BOUNDS FOR EACH? + real(real32), dimension(3,3) :: tfmat end type aspect_type @@ -46,13 +46,12 @@ module aspect subroutine edit_structure(lat,bas,ofile,edits,lnorm) implicit none integer :: GEOMunit,i - type(bas_type) :: edited_bas - double precision, dimension(3,3) :: edited_lat + type(basis_type) :: edited_bas character(len=*), intent(in) :: ofile logical, optional, intent(in) :: lnorm - type(bas_type), intent(in) :: bas + type(basis_type), intent(in) :: bas type(aspect_type), intent(in) :: edits - double precision, dimension(3,3), intent(in) :: lat + real(real32), dimension(3,3), intent(in) :: lat !!! TAKE ORDER OF TASKS FROM THE ARTEMIS USER INPUT @@ -61,9 +60,7 @@ subroutine edit_structure(lat,bas,ofile,edits,lnorm) !!! YEAH, STORE THIS AS AN ASPECT CUSTOM STRUCTURE, CONTAINS LIST AND ALL OF THIS !!! PUT CUSTOM STRUCTURE ELSEWHERE, BUT WRITING IT HERE FOR NOW - call clone_bas(& - inbas=bas,outbas=edited_bas,& - inlat=lat,outlat=edited_lat) + call edited_bas%copy(bas) do i=1,edits%nedits @@ -73,10 +70,10 @@ subroutine edit_structure(lat,bas,ofile,edits,lnorm) case(ishift_region_index) call err_abort('ERROR: SHIFT REGION NOT YET SET UP. ISSUE WITH BOUNDS') case(ivacuum_index) - call vacuumer(edited_lat,edited_bas,& + call vacuumer(edited_bas%lat,edited_bas,& edits%axis(i),edits%bounds(i,1),edits%val(i)) case(itransform_index) - call transformer(lat=edited_lat,bas=edited_bas,tfmat=edits%tfmat) + call transformer(basis=edited_bas,tfmat=edits%tfmat) case(islab_index) call err_abort('ERROR: SLAB PRINTER NOT YET SET UP') end select @@ -84,13 +81,13 @@ subroutine edit_structure(lat,bas,ofile,edits,lnorm) end do if(present(lnorm))then - if(lnorm) call reducer(edited_lat,edited_bas) + if(lnorm) call reducer(edited_bas) end if GEOMunit=101 open(unit=GEOMunit,file=trim(ofile)) - call geom_write(GEOMunit,edited_lat,edited_bas) + call geom_write(GEOMunit,edited_bas) close(GEOMunit) diff --git a/app/default_infile.f90 b/app/default_infile.f90 new file mode 100644 index 0000000..23a37ea --- /dev/null +++ b/app/default_infile.f90 @@ -0,0 +1,137 @@ +module infile_print + !! This module contains a subroutine to print a default input file + implicit none + + + private + + public :: print_default_file + + + +contains + +!############################################################################### + subroutine print_default_file(file) + !! Print a default input file for the program + implicit none + + ! Arguments + character(*), intent(in), optional :: file + !! The name of the file to print to (default = stdout) + + ! Local variables + integer :: unit, status, i + !! unit number, status, and loop counter + logical :: exist + !! logical variable to check if file exists + character(len=16) :: buffer + !! buffer for user input + + + ! Check if file is present + ! If not, use stdout + unit = 6 + if(present(file))then + ! check if file exists + inquire(file=file,exist=exist) + i = 0 + file_overwrite_check: do while(exist) + i = i + 1 + if(i.gt. 10) then + write(0,*) "Too many attempts to overwrite file. Exiting." + return + end if + ! file exists, ask if overwrite + if(i.eq.1) write(*,'("File ",A," already exists. ")',advance='no') trim(adjustl(file)) + write(*,'("Overwrite? (y/n) ")',advance='no') + read(*,'(A)',iostat=status) buffer + if(status .ne. 0) return + buffer = trim(adjustl(buffer)) + select case(buffer(1:1)) + case('y','Y') + ! overwrite + write(*,'(" Overwriting file ",A)') trim(adjustl(file)) + exit file_overwrite_check + case('n','N') + ! do not overwrite, exit + write(*,'(" Exiting without overwriting file ",A)') trim(adjustl(file)) + return + case default + ! invalid input, ask again + write(0,'(" Invalid input. Please enter ''y'' or ''n''.")') + end select + end do file_overwrite_check + open(newunit=unit,file=file,action='write') + end if + + ! Print the default input file + write(unit,'("SETTINGS")') + write(unit,'(2X,"TASK = 1")') + write(unit,'(2X,"RESTART = 0")') + write(unit,'(2X,"STRUC1_FILE = POSCAR1 ! lower structure/interface structure")') + write(unit,'(2X,"STRUC2_FILE = POSCAR2 ! upper structure (not used if RESTART > 0)")') + write(unit,'(2X,"MASTER_DIR = DINTERFACES")') + write(unit,'(2X,"SUBDIR_PREFIX = D")') + write(unit,'(2X,"IPRINT = 0")') + write(unit,'(2X,"CLOCK = ! taken from the time clock by default")') + write(unit,'("END SETTINGS")') + write(unit,*) + write(unit,*) + write(unit,'("CELL_EDITS")') + write(unit,'(2X,"LSURF_GEN = T")') + write(unit,'(2X,"MILLER_PLANE = 1 2 1")') + write(unit,'(2X,"SLAB_THICKNESS = 6")') + write(unit,'("END CELL_EDITS")') + write(unit,*) + write(unit,*) + write(unit,'("INTERFACES")') + write(unit,'(2X,"LGEN_INTERFACES = T ! generate interfaces")') + write(unit,'(2X,"IMATCH = 0 ! interface matching method")') + write(unit,'(2X,"NINTF = 100 ! max number of interfaces")') + write(unit,'(2X,"NMATCH = 5 ! max number of lattice matches")') + write(unit,'(2X,"TOL_VEC = 5.D0 ! max vector tolerance (in percent %)")') + write(unit,'(2X,"TOL_ANG = 1.D0 ! max angle tolerance (in degrees (°))")') + write(unit,'(2X,"TOL_AREA = 10.D0 ! max area tolerance (in percent %)")') + write(unit,'(2X,"TOL_MAXFIND = 100 ! max number of good fits to find per plane")') + write(unit,'(2X,"TOL_MAXSIZE = 10 ! max increase of any lattice vector")') + write(unit,'(2X,"LW_USE_PRICEL = T ! extract and use the primitive cell of lower")') + write(unit,'(2X,"UP_USE_PRICEL = T ! extract and use the primitive cell of upper")') + write(unit,*) + write(unit,'(2X,"NMILLER = 10 ! number of Miller planes to consider")') + write(unit,'(2X,"LW_MILLER = ! written as a miller plane, e.g. 0 0 1")') + write(unit,'(2X,"UP_MILLER = ! written as a miller plane, e.g. 0 0 1")') + write(unit,*) + write(unit,'(2X,"LW_MIN_THICKNESS = 10 ! thickness of lower material (in Angstrom)")') + write(unit,'(2X,"UP_MIN_THICKNESS = 10 ! thickness of upper material (in Angstrom)")') + write(unit,'(2X,"NTERM = 5 ! max number of terminations per material per match")') + write(unit,'(2X,"LW_SURFACE = ! surface to force for interface generation")') + write(unit,'(2X,"UP_SURFACE = ! surface to force for interface generation")') + write(unit,*) + write(unit,'(2X,"SHIFTDIR = DSHIFT ! shift directory name")') + write(unit,'(2X,"ISHIFT = 4 ! shifting method")') + write(unit,'(2X,"NSHIFT = 5 ! number of shifts to apply")') + write(unit,'(2X,"C_SCALE = 1.D0 ! interface-separation scaling factor")') + write(unit,*) + write(unit,'(2X,"SWAPDIR = DSWAP ! swap directory name")') + write(unit,'(2X,"ISWAP = 0 ! swapping method")') + write(unit,'(2X,"NSWAP = 5 ! number of swap structures generated per interface")') + write(unit,'(2X,"SWAP_DENSITY = 5.D-2 ! intermixing area density")') + write(unit,*) + write(unit,'(2X,"LSURF_GEN = F ! generate surfaces of a plane")') + write(unit,'(2X,"LPRINT_TERMS = F ! prints all found terminations")') + write(unit,'(2X,"LPRINT_MATCHES = F ! prints all found lattice matches")') + write(unit,'("END INTERFACES")') + write(unit,*) + !write(unit,*) + !write(unit,'("DEFECTS")') + !write(unit,'("! NOT CURRENTLY IMPLEMENTED")') + !write(unit,'("END DEFECTS")') + + + if(present(file)) close(unit) + + end subroutine print_default_file +!############################################################################### + +end module infile_print diff --git a/src/inputs.f90 b/app/inputs.f90 similarity index 67% rename from src/inputs.f90 rename to app/inputs.f90 index 9e95212..d09a9be 100644 --- a/src/inputs.f90 +++ b/app/inputs.f90 @@ -6,50 +6,94 @@ !!! Isiah Edward Mikel Rudkin !!! Code part of the ARTEMIS group !!!############################################################################# -!!! MAYBE HAVE FINDSYM IN HERE IN ORDER TO EDIT TOLSYM? module inputs - use constants, only: ierror,pi - use misc, only: flagmaker,file_check,to_lower,to_upper - use rw_geom, only: bas_type,geom_read,geom_write - use io + use artemis__constants, only: real32, pi + use artemis__misc, only: flagmaker,file_check + use artemis__geom_rw, only: basis_type,geom_read + use artemis__io_utils, only: & + artemis__version__, & + print_warning, print_header, & + err_abort + use artemis__io_utils_extd, only: setup_input_fmt, setup_output_fmt use aspect, only: aspect_type, edit_structure - use lat_compare, only: lreduce,get_best_match,latmatch_type,tol_type + use lat_compare, only: tol_type use infile_tools use infile_print - use mod_sym, only: set_symmetry_tolerance implicit none - integer :: nout,clock,task,task_defect,axis,icheck_intf,iintf - integer :: irestart,idepth,imatch,ishift,iswap - integer :: lw_thickness,up_thickness - integer :: nshift,nterm,nintf,nswap,nmiller - real :: max_bondlength,swap_sigma,swap_depth - double precision :: lw_bulk_modulus, up_bulk_modulus - double precision :: c_scale,intf_depth,vacuum - double precision :: layer_sep,lw_layer_sep,up_layer_sep,swap_den,tol_sym + + + integer :: max_num_matches, max_num_terms, max_num_planes + !! Maximum number of matches, terminations and Miller planes for matching + logical :: compensate_normal + !! Boolean whether to compensate for mismatch strain by adjusting the + !! interface normal axis + integer :: match_method, shift_method, swap_method, depth_method + !! Integer to determine which method to use for matching, shifting and swapping + integer :: num_shifts + !! Number of shifts to be generated per termination pair + real(real32) :: interface_depth, separation_scale, bondlength_cutoff + !! Interface depth, separation scale, and maximum bondlength considered for + !! the shifting method + real(real32), allocatable, dimension(:,:) :: shifts + !! Array of shifts to be applied to the upper structure in the interface + + integer :: num_swaps + !! Number of swaps to be generated per shift + real(real32) :: swap_density, swap_sigma, swap_depth + !! Swap density, swap sigma and swap depth for the swapping method + logical :: require_mirror_swaps + !! Boolean whether to require swaps to be mirrors on each interface + + logical :: reduce_matches + !! Reduce lattice matches to their smallest cell (UNSTABLE) + + logical :: break_on_fail + integer :: icheck_term_pair, interface_idx + integer :: clock, verbose + + real(real32) :: vacuum_gap + !! Vacuum gap (FOR SURFACE GENERATION ONLY) + logical :: lortho + !! Boolean whether to orthogonalise the lattice (FOR SURFACE GENERATION ONLY) + integer :: max_num_structures + !!! Maximum number of structures to be generated + + integer :: axis + !! Integer to determine which axis to use for the interface + + type(tol_type) :: tolerance + !! Tolerance settings for lattice matchings + + logical :: lw_use_pricel, up_use_pricel + !! Boolean whether to use the primitive cell of the lower and upper + logical :: lw_layered, up_layered + !! Boolean whether the lower and upper structures are layered + logical :: lw_require_stoich, up_require_stoich + !! Boolean whether to require terminations of the lower and upper structures + !! to be stoichiometrically equivalent to their provided structure + + integer :: nout,task,task_defect + integer :: irestart + integer :: lw_num_layers,up_num_layers + real(real32) :: lw_thickness, up_thickness + real(real32) :: lw_bulk_modulus, up_bulk_modulus + real(real32) :: layer_sep,lw_layer_sep,up_layer_sep,tol_sym character(len=20) :: input_fmt,output_fmt character(200) :: struc1_file,struc2_file,out_filename character(100) :: dirname,shiftdir,swapdir,subdir_prefix logical :: lsurf_gen,lprint_matches,lprint_terms,lgen_interfaces,lprint_shifts - logical :: lw_use_pricel, up_use_pricel - logical :: lw_layered,up_layered - logical :: lortho,lnorm_lat + logical :: lnorm_lat logical :: ludef_lw_layered,ludef_up_layered,ludef_axis logical :: lpresent_struc2 - logical :: lswap_mirror - logical :: lc_fix - type(bas_type) :: struc1_bas,struc2_bas - type(tol_type) :: tolerance + type(basis_type) :: struc1_bas,struc2_bas type(aspect_type) :: edits integer, dimension(2) :: lw_surf,up_surf integer, dimension(3) :: lw_mplane,up_mplane integer, allocatable, dimension(:) :: seed - double precision, dimension(2) :: udef_intf_loc - double precision, allocatable, dimension(:,:) :: offset - double precision, dimension(3,3) :: struc1_lat,struc2_lat + real(real32), dimension(2) :: udef_intf_loc + real(real32), dimension(3,3) :: struc1_lat,struc2_lat -!!!updated 2023/03/27 - contains !!!############################################################################# @@ -77,55 +121,58 @@ subroutine set_global_vars() struc2_file="" out_filename="" dirname="DINTERFACES" - shiftdir="DSHIFTS" - swapdir="DSWAPS" + shiftdir="DSHIFT" + swapdir="DSWAP" subdir_prefix="D" n=1 - clock=0 + clock = 0 + verbose = 0 allocate(seed(n)) - imatch=0 - ishift=4 - idepth=0 !!! SWAP DEFAULT DEPTH METHOD !!! - intf_depth=1.5D0 - layer_sep=1.D0 - lw_layer_sep=0.D0 - up_layer_sep=0.D0 + match_method = 0 + shift_method = 4 + depth_method = 0 !!! SWAP DEFAULT DEPTH METHOD !!! + interface_depth = 1.5_real32 + layer_sep=1._real32 + lw_layer_sep=0._real32 + up_layer_sep=0._real32 lortho = .true. lsurf_gen=.false. up_mplane=(/0,0,0/) lw_mplane=(/0,0,0/) axis=3 - lw_thickness=3 - up_thickness=3 - vacuum=14.D0 + lw_num_layers=0 + up_num_layers=0 + lw_thickness=-1._real32 + up_thickness=-1._real32 + vacuum_gap=14._real32 lw_surf=0 up_surf=0 - c_scale=1.5D0 - max_bondlength=4.0 - nmiller=10 - nshift=5 - nterm=5 - nintf=100 - tolerance%nstore=5 - tolerance%maxlen=20.D0 - tolerance%maxarea=400.D0 + separation_scale = 1._real32 + bondlength_cutoff = 4._real32 + max_num_planes = 10 + num_shifts = 5 + max_num_terms = 5 + max_num_structures=100 + max_num_matches=5 + tolerance%maxlen=20._real32 + tolerance%maxarea=400._real32 tolerance%maxfit=100 tolerance%maxsize=10 - tolerance%vec=5.D0 - tolerance%ang=1.D0 - tolerance%area=10.D0 + tolerance%vec=5._real32 + tolerance%ang=1._real32 + tolerance%area=10._real32 lprint_terms=.false. lprint_shifts=.false. lprint_matches=.false. lgen_interfaces=.true. - lreduce=.false. - iswap = 0 - nswap = 5 - swap_den = 5.D-2 + reduce_matches=.false. + swap_method = 0 + num_swaps = 5 + swap_density = 5.E-2_real32 swap_sigma = -1.0 swap_depth = 3.0 - lswap_mirror = .true. - icheck_intf=-1 + require_mirror_swaps = .true. + icheck_term_pair=-1 lw_layered=.false. up_layered=.false. ludef_lw_layered=.false. @@ -134,15 +181,16 @@ subroutine set_global_vars() lnorm_lat=.true. lw_surf=0 up_surf=0 - iintf=-1 - tol_sym = 1.D-6 - udef_intf_loc = [ -1.D0, -1.D0 ] + interface_idx=-1 + tol_sym = 1.E-6_real32 + udef_intf_loc = [ -1._real32, -1._real32 ] lw_use_pricel=.true. up_use_pricel=.true. lw_bulk_modulus=0.E0 up_bulk_modulus=0.E0 - lc_fix=.true. + compensate_normal=.true. + break_on_fail = .true. !!!----------------------------------------------------------------------------- @@ -165,15 +213,15 @@ subroutine set_global_vars() if(.not.empty)then read(buffer,'(A)') input_file else - write(6,'("ERROR: No input filename supplied, but the flag ''-f'' was used")') + write(*,'("ERROR: No input filename supplied, but the flag ''-f'' was used")') infilename_do: do j=1,3 - write(6,'("Please supply an input filename:")') + write(*,'("Please supply an input filename:")') read(5,'(A)') input_file if(trim(input_file).ne.'')then - write(6,'("Input filename supplied")') + write(*,'("Input filename supplied")') exit infilename_do else - write(6,'(1X,"Not a valid filename")') + write(*,'(1X,"Not a valid filename")') end if if(j.eq.3)then call err_abort('ERROR: No valid input filename supplied\nExiting...',.true.) @@ -222,49 +270,49 @@ subroutine set_global_vars() elseif(index(buffer,'-v').eq.1)then flag="-v" call flagmaker(buffer,flag,i,skip,empty) - if(.not.empty) read(buffer,*) ierror + if(.not.empty) read(buffer,*) verbose elseif(index(buffer,'--version').eq.1)then flag="--version" - write(6,'(1X,"ARTEMIS version: ",A)') trim(version) + write(*,'(1X,"ARTEMIS version: ",A)') trim(artemis__version__) stop elseif(index(buffer,'-h').eq.1.or.index(buffer,'--help').eq.1)then flag="--help" if(index(buffer,'-h').eq.1) flag="-h" call flagmaker(buffer,flag,i,skip,empty) if(empty)then - write(6,'("Flags:")') - write(6,'("-----------------FILE-NAME-FLAGS-----------------")') - write(6,'(2X,"-f : Input file name (Default = (empty)). (ALTERNATIVE TO FLAGS)")') - write(6,'(2X,"-i : Structure file 1 (Default = POSCAR)")') - write(6,'(2X,"-I : Structure file 2 (Default = (empty)")') - write(6,'(2X,"-D : Output directory name for generated structures (Default = DInterfaces)")') - write(6,'(2X,"-o : Subdirectory prefix (Default = D)")') - write(6,'("--------------------JOB-FLAGS--------------------")') - write(6,'(2X,"--restart : Restart job from where left off (NOT YET IMPLEMENTED)")') - write(6,'(2X,"--gen-surfaces : Generates the surfaces and labels them (NOT YET IMPLEMENTED)")') - write(6,'("------------------VERBOSE-FLAGS------------------")') - write(6,'(2X,"--version : Prints the version number")') - write(6,'(2X,"-v : Verbose printing type")') - write(6,'(2X,"-d[STR] : Print example input file (to file STR if present)")') - write(6,'(2X,"-h|--help [tag] : Prints the help for flags and tags (describes [tag] if supplied)")') - write(6,'(2X," "" all : Prints a list of all input file tags")') - write(6,'(2X,"--search : Searches the help for tags including the string ")') + write(*,'("Flags:")') + write(*,'("-----------------FILE-NAME-FLAGS-----------------")') + write(*,'(2X,"-f : Input file name (Default = (empty)). (ALTERNATIVE TO FLAGS)")') + write(*,'(2X,"-i : Structure file 1 (Default = POSCAR)")') + write(*,'(2X,"-I : Structure file 2 (Default = (empty)")') + write(*,'(2X,"-D : Output directory name for generated structures (Default = DInterfaces)")') + write(*,'(2X,"-o : Subdirectory prefix (Default = D)")') + write(*,'("--------------------JOB-FLAGS--------------------")') + write(*,'(2X,"--restart : Restart job from where left off (NOT YET IMPLEMENTED)")') + write(*,'(2X,"--gen-surfaces : Generates the surfaces and labels them (NOT YET IMPLEMENTED)")') + write(*,'("------------------VERBOSE-FLAGS------------------")') + write(*,'(2X,"--version : Prints the version number")') + write(*,'(2X,"-v : Verbose printing type")') + write(*,'(2X,"-d[STR] : Print example input file (to file STR if present)")') + write(*,'(2X,"-h|--help [tag] : Prints the help for flags and tags (describes [tag] if supplied)")') + write(*,'(2X," "" all : Prints a list of all input file tags")') + write(*,'(2X,"--search : Searches the help for tags including the string ")') else - write(6,*) + write(*,*) call settings_help(6,trim(adjustl(buffer))) call cell_edits_help(6,trim(adjustl(buffer))) call interface_help(6,trim(adjustl(buffer))) - write(6,'("======================================")') + write(*,'("======================================")') end if stop elseif(index(buffer,'--search').eq.1)then flag="--search" - write(6,*) + write(*,*) call flagmaker(buffer,flag,i,skip,empty) call settings_help(6,trim(adjustl(buffer)),search=.true.) call cell_edits_help(6,trim(adjustl(buffer)),search=.true.) call interface_help(6,trim(adjustl(buffer)),search=.true.) - write(6,'("======================================")') + write(*,'("======================================")') stop end if end do flagloop @@ -280,7 +328,7 @@ subroutine set_global_vars() !!! print execution date and time !!!----------------------------------------------------------------------------- call date_and_time(values=date_time_vals) - write(6,'(" executed on ",& + write(*,'(" executed on ",& &I4,".",I2.2,".",I2.2," at ",& &I0,":",I0,":",I0)')& date_time_vals(1:3),date_time_vals(5:7) @@ -309,9 +357,9 @@ subroutine set_global_vars() !!!----------------------------------------------------------------------------- !!! readjust interface tolerances !!!----------------------------------------------------------------------------- - tolerance%vec=tolerance%vec/100.D0 - tolerance%ang=tolerance%ang*pi/180.D0 - tolerance%area=tolerance%area/100.D0 + tolerance%vec=tolerance%vec/100._real32 + tolerance%ang=tolerance%ang*pi/180._real32 + tolerance%area=tolerance%area/100._real32 !!!----------------------------------------------------------------------------- @@ -322,7 +370,7 @@ subroutine set_global_vars() seed = clock + 37 * (/ (i - 1, i = 1, n) /) call random_seed(put=seed) - write(6,'(1X,A,I0)') "clock seed: ",clock + write(*,'(1X,A,I0)') "clock seed: ",clock !!!----------------------------------------------------------------------------- @@ -330,7 +378,7 @@ subroutine set_global_vars() !!!----------------------------------------------------------------------------- GEOMunit=10 call file_check(GEOMunit,struc1_file) - call geom_read(GEOMunit,struc1_lat,struc1_bas,4) + call geom_read(GEOMunit,struc1_bas,4) close(GEOMunit) lpresent_struc2 = .false. !!-------------------------------------------------------------------------- @@ -339,8 +387,8 @@ subroutine set_global_vars() if( (irestart.eq.1.and.task.eq.1).or.& (lsurf_gen.and.task.eq.1.and.struc2_file.eq.'').or.& (task.eq.0.and.struc2_file.eq.'') )then - write(6,'("2nd structure file not supplied")') - write(6,'(2X,"As is not necessary for this run, skipping...")') + write(*,'("2nd structure file not supplied")') + write(*,'(2X,"As is not necessary for this run, skipping...")') elseif(struc2_file.eq.'')then call err_abort('ERROR: 2nd structure file not supplied\n& & Supply a filename to the tag STRUC2_FILE in the SETTINGS card\n& @@ -352,7 +400,7 @@ subroutine set_global_vars() lpresent_struc2 = .true. GEOMunit=11 call file_check(GEOMunit,struc2_file) - call geom_read(GEOMunit,struc2_lat,struc2_bas,4) + call geom_read(GEOMunit,struc2_bas,4) close(GEOMunit) end if @@ -360,16 +408,10 @@ subroutine set_global_vars() !!!----------------------------------------------------------------------------- !!! changes interface depth depending on IDEPTH method !!!----------------------------------------------------------------------------- - if(idepth.eq.0) intf_depth=0.D0 + if(depth_method.eq.0) interface_depth=0._real32 -!!!----------------------------------------------------------------------------- -!!! sets the symmetry tolerance for the mod_sym module -!!!----------------------------------------------------------------------------- - call set_symmetry_tolerance(tol_sym) - - !!!----------------------------------------------------------------------------- !!! make the output directory !!!----------------------------------------------------------------------------- @@ -378,8 +420,22 @@ subroutine set_global_vars() call write_settings(adjustl(trim(dirname))) end if - write(6,'(A)') repeat("#",50) + write(*,'(A)') repeat("#",50) + if(lw_thickness.gt.0._real32.and.lw_num_layers.gt.0)then + write(0,'(1X,A)') "WARNING: SLAB THICKNESS AND NUMBER OF LAYERS BOTH DEFINED" + write(0,'(1X,A)') " SLAB THICKNESS OVERRIDES NUMBER OF LAYERS" + lw_num_layers=0 + elseif(lw_thickness.le.0._real32.and.lw_num_layers.le.0)then + lw_thickness = 10._real32 + end if + if(up_thickness.gt.0._real32.and.up_num_layers.gt.0)then + write(0,'(1X,A)') "WARNING: SLAB THICKNESS AND NUMBER OF LAYERS BOTH DEFINED" + write(0,'(1X,A)') " SLAB THICKNESS OVERRIDES NUMBER OF LAYERS" + up_num_layers=0 + elseif(up_thickness.le.0._real32.and.up_num_layers.le.0)then + up_thickness = 10._real32 + end if return end subroutine set_global_vars @@ -496,7 +552,7 @@ subroutine read_card_settings(unit,count,skip) case("SUBDIR_PREFIX") call assign(buffer,subdir_prefix,readvar(6)) case("IPRINT") - call assign(buffer,ierror, readvar(7)) + call assign(buffer,verbose, readvar(7)) case("CLOCK") call assign(buffer,clock, readvar(8)) case("INPUT_FMT") @@ -506,7 +562,7 @@ subroutine read_card_settings(unit,count,skip) case("TOL_SYM") call assign(buffer,tol_sym, readvar(11)) case default - write(6,'("NOTE: unable to assign variable on line ",I0)') count + write(*,'("NOTE: unable to assign variable on line ",I0)') count end select end do settings_read @@ -536,7 +592,7 @@ subroutine read_card_cell_edits(unit,count,skip) character(1024) :: buffer,tagname,store integer, intent(in) :: unit integer, intent(inout) :: count - integer, dimension(12) :: readvar + integer, dimension(15) :: readvar logical, optional, intent(in) :: skip character(len=6), dimension(4) :: & tag_list = ["axis ","loc ","val ","bounds"] @@ -566,8 +622,11 @@ subroutine read_card_cell_edits(unit,count,skip) call assign(buffer,lsurf_gen, readvar(2)) case("MILLER_PLANE") call assign_vec(buffer,lw_mplane, readvar(3)) - case("SLAB_THICKNESS") - call assign(buffer,lw_thickness, readvar(4)) + case("NUM_LAYERS", "SLAB_THICKNESS") + if(index(buffer,"SLAB_THICKNESS").ne.0)then + write(0,'(1X,A)') "WARNING: SLAB_THICKNESS is deprecated, use NUM_LAYERS instead" + end if + call assign(buffer,lw_num_layers, readvar(4)) case("SHIFT") edits%nedits=edits%nedits+1 store=buffer(index(buffer,"SHIFT")+len("SHIFT"):) @@ -575,8 +634,8 @@ subroutine read_card_cell_edits(unit,count,skip) call cat(unit=unit,end_string="END",end_string2="SHIFT",& line=count,string=store,rm_cmt=.true.) end if - edits%axis(edits%nedits)=assign_list(store,tag_list,1) - edits%val(edits%nedits)=assign_list(store,tag_list,3) + edits%axis(edits%nedits)= nint( assign_list(store,tag_list,1) ) + edits%val(edits%nedits)= assign_list(store,tag_list,3) if(index(store,"bounds").eq.0)then readvar(5) = readvar(5) + 1 edits%list(edits%nedits)=1 @@ -593,11 +652,11 @@ subroutine read_card_cell_edits(unit,count,skip) readvar(7) = readvar(7) + 1 call cat(unit=unit,end_string="END",end_string2="VACUUM",& line=count,string=store,rm_cmt=.true.) - edits%axis(edits%nedits)=assign_list(store,tag_list,1) + edits%axis(edits%nedits)= nint( assign_list(store,tag_list,1) ) edits%bounds(edits%nedits,1)=assign_list(store,tag_list,2) edits%val(edits%nedits)=assign_list(store,tag_list,3) else - call assign(buffer, vacuum, readvar(7)) + call assign(buffer, vacuum_gap, readvar(7)) end if case("TFMAT") readvar(8) = readvar(8) + 1 @@ -621,9 +680,15 @@ subroutine read_card_cell_edits(unit,count,skip) read(store,*) lw_surf end select case("LNORM_LAT") - call assign(buffer,lnorm_lat, readvar(12)) + call assign(buffer,lnorm_lat, readvar(12)) + case("MIN_THICKNESS") + call assign(buffer,lw_thickness, readvar(13)) + case("USE_PRICEL") + call assign(buffer,lw_use_pricel, readvar(14)) + case("REQUIRE_STOICH") + call assign(buffer,lw_require_stoich, readvar(15)) case default - write(6,'("NOTE: unable to assign variable on line ",I0)') count + write(*,'("NOTE: unable to assign variable on line ",I0)') count end select end do cell_edits_read @@ -652,14 +717,14 @@ subroutine read_card_interfaces(unit,count,skip) integer :: Reason,j,iudef_nshift character(1024) :: store character(1024) :: buffer,tagname - logical :: ludef_offset, ludef_lw_layer_sep, ludef_up_layer_sep + logical :: ludef_shifts, ludef_lw_layer_sep, ludef_up_layer_sep integer, intent(in) :: unit integer, intent(inout) :: count - integer, dimension(54) :: readvar + integer, dimension(59) :: readvar logical, optional, intent(in) :: skip - ludef_offset=.false. + ludef_shifts=.false. ludef_lw_layer_sep=.false. ludef_up_layer_sep=.false. readvar=0 @@ -682,10 +747,16 @@ subroutine read_card_interfaces(unit,count,skip) case("AXIS") ludef_axis=.true. call assign(buffer,axis, readvar(2)) - case("LW_SLAB_THICKNESS") - call assign(buffer,lw_thickness, readvar(3)) - case("UP_SLAB_THICKNESS") - call assign(buffer,up_thickness, readvar(4)) + case("LW_NUM_LAYERS", "LW_SLAB_THICKNESS") + if(index(buffer,"LW_SLAB_THICKNESS").ne.0)then + write(0,'(1X,A)') "WARNING: LW_SLAB_THICKNESS is deprecated, use LW_NUM_LAYERS instead" + end if + call assign(buffer,lw_num_layers, readvar(3)) + case("UP_NUM_LAYERS", "UP_SLAB_THICKNESS") + if(index(buffer,"UP_SLAB_THICKNESS").ne.0)then + write(0,'(1X,A)') "WARNING: UP_SLAB_THICKNESS is deprecated, use UP_NUM_LAYERS instead" + end if + call assign(buffer,up_num_layers, readvar(4)) case("LW_MILLER") call assign_vec(buffer,lw_mplane, readvar(5)) case("UP_MILLER") @@ -709,7 +780,7 @@ subroutine read_card_interfaces(unit,count,skip) read(store,*) up_surf end select case("SHIFT") - ludef_offset=.true. + ludef_shifts=.true. iudef_nshift=0 store='' store=buffer(index(buffer,"SHIFT")+len("SHIFT"):) @@ -719,119 +790,129 @@ subroutine read_card_interfaces(unit,count,skip) line=iudef_nshift,string=store,rm_cmt=.true.) count=count+iudef_nshift iudef_nshift=iudef_nshift-1 !removes counting of ENDSHIFT line - allocate(offset(iudef_nshift,3)) - read(store,*) (offset(j,:3),j=1,iudef_nshift) + allocate(shifts(iudef_nshift,3)) + read(store,*) (shifts(j,:3),j=1,iudef_nshift) else call assign(buffer,store, readvar(9)) - allocate(offset(1,3)) + allocate(shifts(1,3)) select case(icount(store)) case(1) - offset(1,:)=0.D0 - read(store,*) offset(1,3) + shifts(1,:)=0._real32 + read(store,*) shifts(1,3) iudef_nshift = 1 case(3) - read(store,*) offset(1,:) - if(all(offset.ge.0.D0)) iudef_nshift=1 + read(store,*) shifts(1,:) + if(all(shifts.ge.0._real32)) iudef_nshift=1 case default call err_abort('ERROR: Invalid number of arguments provided to SHIFT& &\nValid number of arguments is 1 or 3.&') end select end if case("NSHIFT") - call assign(buffer,nshift, readvar(10)) + call assign(buffer,num_shifts, readvar(10)) case("NTERM") - call assign(buffer,nterm, readvar(11)) + call assign(buffer,max_num_terms, readvar(11)) case("NMATCH") - call assign(buffer,tolerance%nstore, readvar(12)) + call assign(buffer,max_num_matches, readvar(12)) case("TOL_VEC") - call assign(buffer,tolerance%vec, readvar(13)) + call assign(buffer,tolerance%vec, readvar(13)) case("TOL_ANG") - call assign(buffer,tolerance%ang, readvar(14)) + call assign(buffer,tolerance%ang, readvar(14)) case("TOL_AREA") - call assign(buffer,tolerance%area, readvar(15)) + call assign(buffer,tolerance%area, readvar(15)) case("TOL_MAXFIND") - call assign(buffer,tolerance%maxfit, readvar(16)) + call assign(buffer,tolerance%maxfit, readvar(16)) case("TOL_MAXSIZE") - call assign(buffer,tolerance%maxsize,readvar(17)) + call assign(buffer,tolerance%maxsize, readvar(17)) case("LPRINT_MATCHES") - call assign(buffer,lprint_matches, readvar(18)) + call assign(buffer,lprint_matches, readvar(18)) case("LPRINT_TERMS") - call assign(buffer,lprint_terms, readvar(19)) + call assign(buffer,lprint_terms, readvar(19)) case("LGEN_INTERFACES") - call assign(buffer,lgen_interfaces, readvar(20)) + call assign(buffer,lgen_interfaces, readvar(20)) case("IMATCH") - call assign(buffer,imatch, readvar(21)) + call assign(buffer,match_method, readvar(21)) case("ISHIFT") - call assign(buffer,ishift, readvar(22)) + call assign(buffer,shift_method, readvar(22)) case("LREDUCE") - call assign(buffer,lreduce, readvar(23)) + call assign(buffer,reduce_matches, readvar(23)) case("LPRINT_SHIFTS") - call assign(buffer,lprint_shifts, readvar(24)) + call assign(buffer,lprint_shifts, readvar(24)) case("C_SCALE") - call assign(buffer,c_scale, readvar(25)) + call assign(buffer,separation_scale, readvar(25)) case("INTF_DEPTH") - call assign(buffer,intf_depth, readvar(26)) - idepth=0 + call assign(buffer,interface_depth, readvar(26)) + depth_method=0 case("IDEPTH") - call assign(buffer,idepth, readvar(27)) + call assign(buffer,depth_method, readvar(27)) case("NINTF") - call assign(buffer,nintf, readvar(28)) + call assign(buffer,max_num_structures, readvar(28)) case("ISWAP") - call assign(buffer,iswap, readvar(29)) + call assign(buffer,swap_method, readvar(29)) case("NSWAP") - call assign(buffer,nswap, readvar(30)) + call assign(buffer,num_swaps, readvar(30)) case("SWAP_DENSITY") - call assign(buffer,swap_den, readvar(31)) + call assign(buffer,swap_density, readvar(31)) case("SHIFTDIR") - call assign(buffer,shiftdir, readvar(32)) + call assign(buffer,shiftdir, readvar(32)) case("SWAPDIR") - call assign(buffer,swapdir, readvar(33)) + call assign(buffer,swapdir, readvar(33)) case("ICHECK") - call assign(buffer,icheck_intf, readvar(34)) + call assign(buffer,icheck_term_pair, readvar(34)) case("NMILLER") - call assign(buffer,nmiller, readvar(35)) + call assign(buffer,max_num_planes, readvar(35)) case("MAXLEN") - call assign(buffer,tolerance%maxlen, readvar(36)) + call assign(buffer,tolerance%maxlen, readvar(36)) case("MAXAREA") - call assign(buffer,tolerance%maxarea,readvar(37)) + call assign(buffer,tolerance%maxarea, readvar(37)) case("LW_LAYERED") - call assign(buffer,lw_layered, readvar(38)) + call assign(buffer,lw_layered, readvar(38)) ludef_lw_layered=.true. case("UP_LAYERED") - call assign(buffer,up_layered, readvar(39)) + call assign(buffer,up_layered, readvar(39)) ludef_up_layered=.true. case("IINTF") - call assign(buffer,iintf, readvar(40)) + call assign(buffer,interface_idx, readvar(40)) case("LAYER_SEP") - call assign(buffer,layer_sep, readvar(41)) + call assign(buffer,layer_sep, readvar(41)) case("LW_LAYER_SEP") - call assign(buffer,lw_layer_sep, readvar(42)) + call assign(buffer,lw_layer_sep, readvar(42)) ludef_lw_layer_sep=.true. case("UP_LAYER_SEP") - call assign(buffer,up_layer_sep, readvar(43)) + call assign(buffer,up_layer_sep, readvar(43)) ludef_up_layer_sep=.true. case("MBOND_MAXLEN") - call assign(buffer,max_bondlength, readvar(44)) + call assign(buffer,bondlength_cutoff, readvar(44)) case("SWAP_SIGMA") - call assign(buffer,swap_sigma, readvar(45)) + call assign(buffer,swap_sigma, readvar(45)) case("SWAP_DEPTH") - call assign(buffer,swap_depth, readvar(46)) + call assign(buffer,swap_depth, readvar(46)) case("INTF_LOC") - call assign_vec(buffer,udef_intf_loc,readvar(47)) + call assign_vec(buffer,udef_intf_loc, readvar(47)) case("LMIRROR") - call assign(buffer,lswap_mirror, readvar(48)) + call assign(buffer,require_mirror_swaps, readvar(48)) case("LORTHO") - call assign(buffer,lortho, readvar(49)) + call assign(buffer,lortho, readvar(49)) case("LW_USE_PRICEL") - call assign(buffer,lw_use_pricel, readvar(50)) + call assign(buffer,lw_use_pricel, readvar(50)) case("UP_USE_PRICEL") - call assign(buffer,up_use_pricel, readvar(51)) + call assign(buffer,up_use_pricel, readvar(51)) case("LW_BULK_MODULUS") - call assign(buffer,lw_bulk_modulus, readvar(52)) + call assign(buffer,lw_bulk_modulus, readvar(52)) case("UP_BULK_MODULUS") - call assign(buffer,up_bulk_modulus, readvar(53)) + call assign(buffer,up_bulk_modulus, readvar(53)) case("LC_FIX") - call assign(buffer,lc_fix, readvar(54)) + call assign(buffer,compensate_normal, readvar(54)) + case("LBREAK_ON_NO_TERM") + call assign(buffer,break_on_fail, readvar(55)) + case("LW_MIN_THICKNESS") + call assign(buffer,lw_thickness, readvar(56)) + case("UP_MIN_THICKNESS") + call assign(buffer,up_thickness, readvar(57)) + case("LW_REQUIRE_STOICH") + call assign(buffer,lw_require_stoich, readvar(58)) + case("UP_REQUIRE_STOICH") + call assign(buffer,up_require_stoich, readvar(59)) case default write(0,'("NOTE: unable to assign variable on line ",I0)') count end select @@ -839,30 +920,30 @@ subroutine read_card_interfaces(unit,count,skip) if(readvar(25).eq.0)then - select case(ishift) + select case(shift_method) case(0,4) - c_scale = 1.D0 + separation_scale = 1._real32 end select end if - if(ludef_offset)then - if(readvar(22).eq.1.and.ishift.ne.0.and.all(offset.ge.0.D0))then - write(0,*) "ISHIFT = ",ishift - write(0,*) "SHIFT = ",offset + if(ludef_shifts)then + if(readvar(22).eq.1.and.shift_method.ne.0.and.all(shifts.ge.0._real32))then + write(0,*) "ISHIFT = ",shift_method + write(0,*) "SHIFT = ",shifts call err_abort('ERROR: Contradictory tags used (ISHIFT and SHIFT) & &\nNo free shifting directions available& &\nExiting...',.true.) - elseif(readvar(22).eq.1.and.ishift.ne.0.and.size(offset(:,1),dim=1).gt.1)then + elseif(readvar(22).eq.1.and.shift_method.ne.0.and.size(shifts(:,1),dim=1).gt.1)then call err_abort('ERROR: Contradictory tags used (ISHIFT and SHIFT) & &\nExiting...',.true.) - elseif(all(offset.ge.0.D0))then - ishift=0 - nshift=iudef_nshift + elseif(all(shifts.ge.0._real32))then + shift_method=0 + num_shifts=iudef_nshift end if else - allocate(offset(1,3)) - offset(1,:)=(/-1.D0,-1.D0,-1.D0/) + allocate(shifts(1,3)) + shifts(1,:)=(/-1._real32,-1._real32,-1._real32/) end if ! set lw_ and up_layer_sep if not defined @@ -920,7 +1001,7 @@ subroutine read_card_defects(unit,count,skip) !! defect task 1 = doper !! defect task 2 = molec rotater case default - write(6,'("NOTE: unable to assign variable on line ",I0)') count + write(*,'("NOTE: unable to assign variable on line ",I0)') count end select end do defects_read @@ -973,29 +1054,29 @@ subroutine write_settings(dirname) elseif(task.eq.1)then write(UNIT,'("INTERFACES")') write(UNIT,'(2X,"LGEN_INTERFACES = ",L)') lgen_interfaces - write(UNIT,'(2X,"NINTF = ",I0)') nintf - write(UNIT,'(2X,"IMATCH = ",I0)') imatch - write(UNIT,'(2X,"NMATCH = ",I0)') tolerance%nstore + write(UNIT,'(2X,"NINTF = ",I0)') max_num_structures + write(UNIT,'(2X,"IMATCH = ",I0)') match_method + write(UNIT,'(2X,"NMATCH = ",I0)') max_num_matches write(UNIT,'(2X,"TOL_VEC = ",F0.7)') tolerance%vec*100 write(UNIT,'(2X,"TOL_ANG = ",F0.7)') tolerance%ang*360/(2*pi) write(UNIT,'(2X,"TOL_AREA = ",F0.7)') tolerance%area*100 write(UNIT,*) - write(UNIT,'(2X,"NMILLER = ",3(I0,1X))') nmiller + write(UNIT,'(2X,"NMILLER = ",3(I0,1X))') max_num_planes write(UNIT,'(2X,"LW_MILLER_PLANE = ",3(I0,1X))') lw_mplane write(UNIT,'(2X,"UP_MILLER_PLANE = ",3(I0,1X))') up_mplane - write(UNIT,'(2X,"LW_SLAB_THICKNESS = ",I0)') lw_thickness - write(UNIT,'(2X,"UP_SLAB_THICKNESS = ",I0)') up_thickness + write(UNIT,'(2X,"LW_SLAB_THICKNESS = ",I0)') lw_num_layers + write(UNIT,'(2X,"UP_SLAB_THICKNESS = ",I0)') up_num_layers if(ludef_lw_layered) write(UNIT,'(2X,"LW_LAYERED = ",L)') lw_layered if(ludef_up_layered) write(UNIT,'(2X,"UP_LAYERED = ",L)') lw_layered - write(UNIT,'(2X,"NTERM = ",I0)') nterm + write(UNIT,'(2X,"NTERM = ",I0)') max_num_terms write(UNIT,*) - write(UNIT,'(2X,"ISHIFT = ",I0)') ishift - write(UNIT,'(2X,"NSHIFT = ",I0)') nshift - write(UNIT,'(2X,"C_SCALE = ",F0.7)') c_scale + write(UNIT,'(2X,"ISHIFT = ",I0)') shift_method + write(UNIT,'(2X,"NSHIFT = ",I0)') num_shifts + write(UNIT,'(2X,"C_SCALE = ",F0.7)') separation_scale write(UNIT,*) - write(UNIT,'(2X,"ISWAP = ",I0)') iswap - write(UNIT,'(2X,"NSWAP = ",I0)') nswap - write(UNIT,'(2X,"SWAP_DENSITY = ",F0.5)') swap_den + write(UNIT,'(2X,"ISWAP = ",I0)') swap_method + write(UNIT,'(2X,"NSWAP = ",I0)') num_swaps + write(UNIT,'(2X,"SWAP_DENSITY = ",F0.5)') swap_density write(UNIT,*) write(UNIT,'(2X,"LSURF_GEN = ",L1)') lsurf_gen write(UNIT,'("END INTERFACES")') @@ -1015,5 +1096,4 @@ subroutine write_settings(dirname) end subroutine write_settings !!!############################################################################ - end module inputs diff --git a/app/main.f90 b/app/main.f90 new file mode 100644 index 0000000..3a13d4d --- /dev/null +++ b/app/main.f90 @@ -0,0 +1,269 @@ +!!!############################################################################# +!!! ARTEMIS +!!! Code written by Ned Thaddeus Taylor and Francis Huw Davies +!!! Code part of the ARTEMIS group (Hepplestone research group). +!!! Think Hepplestone, think HRG. +!!!############################################################################# +program artemis_executable + use artemis + use inputs + implicit none + + + integer :: i, j, unit + integer, dimension(:), allocatable :: match_and_term_idx_list, idx_list(:) + character(len=256) :: filepath, filename + type(artemis_generator_type) :: generator + type(basis_type), allocatable, dimension(:) :: structures + + + +!!!----------------------------------------------------------------------------- +!!! set up global variables +!!!----------------------------------------------------------------------------- + call set_global_vars() + generator%tol_sym = tol_sym + + +!!!----------------------------------------------------------------------------- +!!! checks what task has been called and starts the appropriate codes +!!!----------------------------------------------------------------------------- +!!! SEARCH = Substitutions, Extension, Additions & Rotations for Creating Heterostructures +!!! ASPECT = Additions, Substitutions & Positional Editing of Crystals Tool +!!! ARTEMIS = Ab initio Restructuring Tool Enabling Modelling of Interface Structures +!!! ARTIE = Alloying & Rotating Tool for Intermixed structure Editing ??? + select case(task) + case(0) ! cell_edit/ASPECT + write(*,'(1X,"task ",I0," set",/,1X,"Performing Cell Edits")') task + if(lsurf_gen)then + write(0,'(1X,"Finding terminations for lower material.")') + + call generator%set_tolerance( & + tolerance = tolerance & + ) + call generator%set_materials( & + structure_lw = struc1_bas, & + use_pricel_lw = lw_use_pricel & + ) + call generator%set_surface_properties( & + miller_lw = lw_mplane, & + is_layered_lw = lw_layered, & + require_stoichiometry_lw = lw_require_stoich, & + vacuum_gap = vacuum_gap, & + layer_separation_cutoff = layer_sep & + ) + + structures = generator%get_terminations(1, & + surface = lw_surf, & + num_layers = lw_num_layers, & + thickness = lw_thickness, & + orthogonalise = lortho, & + print_termination_info = lprint_terms, & + verbose = verbose & + ) + filepath = "DTERMINATIONS" + call system("mkdir -p " // trim(filepath)) + do i = 1, size(structures) + write(filename, '(A,"/POSCAR_term",I0)') & + trim(adjustl(filepath)), i + open(newunit=unit, status='replace', file=trim(filename)) + call geom_write(unit, structures(i)) + close(unit) + end do + write(0,'(1X,"Terminations printed.",/,1X,"Exiting...")') + stop + end if + call edit_structure(& + lat=struc1_lat,bas=struc1_bas,& + ofile=out_filename,edits=edits,& + lnorm=lnorm_lat) + + case(1) ! interfaces/ARTEMIS/SEARCH + write(*,'(1X,"task ",I0," set",/,1X,"Performing Interface Generation")') task + generator%max_num_structures = max_num_structures + generator%axis = axis + call generator%set_tolerance( & + tolerance = tolerance & + ) + call generator%set_match_method( & + method = match_method, & + max_num_matches = max_num_matches, & ! this is maxfit/nstore + max_num_terms = max_num_terms, & + max_num_planes = max_num_planes, & + compensate_normal = compensate_normal & + ) + call generator%set_shift_method( & + method = shift_method, & + num_shifts = num_shifts, & + shifts = shifts, & + interface_depth = interface_depth, & + separation_scale = separation_scale, & + depth_method = depth_method, & + bondlength_cutoff = bondlength_cutoff & + ) + call generator%set_swap_method( & + method = swap_method, & + num_swaps = num_swaps, & + swap_density = swap_density, & + swap_depth = swap_depth, & + swap_sigma = swap_sigma, & + require_mirror_swaps = require_mirror_swaps & + ) + call generator%set_materials( & + structure_lw = struc1_bas, structure_up = struc2_bas, & + use_pricel_lw = lw_use_pricel, use_pricel_up = up_use_pricel, & + elastic_lw = reshape([ lw_bulk_modulus ], shape=[1,1]), & + elastic_up = reshape([ up_bulk_modulus ], shape=[1,1]) & + ) + call generator%set_surface_properties( & + miller_lw = lw_mplane, miller_up = up_mplane, & + is_layered_lw = lw_layered, is_layered_up = up_layered, & + require_stoichiometry_lw = lw_require_stoich, & + require_stoichiometry_up = up_require_stoich, & + layer_separation_cutoff = [ lw_layer_sep, up_layer_sep ], & + vacuum_gap = vacuum_gap & + ) + if(.not.ludef_lw_layered) call generator%reset_is_layered_lw() + if(.not.ludef_up_layered) call generator%reset_is_layered_up() + + !!------------------------------------------------------------------------- + !! surface generator + !!------------------------------------------------------------------------- + if(lsurf_gen)then + if(all(lw_mplane.eq.0))then + write(*,'("No Miller plane defined for lower material.")') + write(*,'("Skipping...")') + else + write(*,'(1X,"Finding terminations for lower material.")') + structures = generator%get_terminations(1, & + surface = lw_surf, & + num_layers = lw_num_layers, & + thickness = lw_thickness, & + orthogonalise = lortho, & + print_termination_info = lprint_terms, & + verbose = verbose & + ) + filepath = "DTERMINATIONS/DLW_TERMS" + call system("mkdir -p " // trim(filepath)) + do i = 1, size(structures) + write(filename, '(A,"/POSCAR_term",I0)') & + trim(adjustl(filepath)), i + open(newunit=unit, status='replace', file=trim(filename)) + call geom_write(unit, structures(i)) + close(unit) + end do + end if + if(all(up_mplane.eq.0))then + write(*,'("No Miller plane defined for upper material.")') + write(*,'("Skipping...")') + else + write(*,'(1X,"Finding terminations for upper material.")') + structures = generator%get_terminations(2, & + surface = up_surf, & + num_layers = up_num_layers, & + thickness = up_thickness, & + orthogonalise = lortho, & + print_termination_info = lprint_terms, & + verbose = verbose & + ) + filepath = "DTERMINATIONS/DUP_TERMS" + call system("mkdir -p " // trim(filepath)) + do i = 1, size(structures) + write(filename, '(A,"/POSCAR_term",I0)') & + trim(adjustl(filepath)), i + open(newunit=unit, status='replace', file=trim(filename)) + call geom_write(unit, structures(i)) + close(unit) + end do + end if + write(*,'(1X,"Terminations printed.",/,1X,"Exiting...")') + stop + end if + + + !!------------------------------------------------------------------------- + !! interface generator + !!------------------------------------------------------------------------- + if(irestart.eq.0)then + call generator%generate( & + surface_lw = lw_surf, surface_up = up_surf, & + thickness_lw = lw_thickness, thickness_up = up_thickness, & + num_layers_lw = lw_num_layers, num_layers_up = up_num_layers, & + reduce_matches = reduce_matches, & + print_lattice_match_info = lprint_matches, & + print_termination_info = lprint_terms, & + print_shift_info = lprint_shifts, & + break_on_fail = break_on_fail, & + icheck_term_pair = icheck_term_pair, & + interface_idx = interface_idx, & + seed = clock, & + verbose = verbose & + ) + else + call generator%regenerate(struc1_bas) + end if + allocate(match_and_term_idx_list(0)) + do i = 1, generator%num_structures + write(filepath, '(A,"/",A,I0.2)') & + trim(adjustl(dirname)), & + trim(adjustl(subdir_prefix)), & + generator%structure_data(i)%match_and_term_idx + if(all(generator%structure_data(1:i-1:1)%match_and_term_idx.ne.generator%structure_data(i)%match_and_term_idx))then + call system("mkdir -p " // trim(filepath)) + call generator%write_match_and_term_data(i, & + directory = trim(filepath), & + filename = "struc_data.txt" & + ) + match_and_term_idx_list = [ match_and_term_idx_list, generator%structure_data(i)%match_and_term_idx ] + end if + if(generator%structure_data(i)%shift_idx.gt.0)then + write(filepath, '(A,"/",A,"/",A,I0.2)') & + trim(adjustl(filepath)), trim(adjustl(shiftdir)), & + trim(adjustl(subdir_prefix)), & + generator%structure_data(i)%shift_idx + end if + if(generator%structure_data(i)%swap_idx.gt.0)then + write(filepath, '(A,"/",A,"/",A,I0.2)') & + trim(adjustl(filepath)), & + trim(adjustl(swapdir)), & + trim(adjustl(subdir_prefix)), & + generator%structure_data(i)%swap_idx + end if + call system("mkdir -p " // trim(filepath)) + write(filename, '(A,"/",A)') trim(filepath), "POSCAR" + open(newunit=unit, status='replace', file=trim(filename)) + call geom_write(unit, generator%structures(i)) + close(unit) + end do + ! get all indices with the same match_idx + ! write the shift data associated with all of them + do i = 1, size(match_and_term_idx_list) + idx_list = pack([(j, j=1, generator%num_structures)], & + generator%structure_data(:)%match_and_term_idx .eq. match_and_term_idx_list(i) ) + if(size(idx_list).eq.0) cycle + write(filepath, '(A,"/",A,I0.2,"/",A)') & + trim(dirname), & + trim(subdir_prefix), & + generator%structure_data(idx_list(1))%match_and_term_idx, & + trim(shiftdir) + call generator%write_shift_data(idx_list, & + directory = trim(filepath), & + filename = "shift_data.txt" & + ) + end do + + + case(2) ! defects/ARTIE + write(*,'(1X,"task ",I0," set",/,1X,"Performing Defect Generation")') task + + + case default + write(*,'(1X,"No task selected.")') + write(*,'(1X,"Exiting code...")') + call exit() + end select + + + +end program artemis_executable + diff --git a/src/lib/mod_tools_infile.f90 b/app/mod_tools_infile.f90 similarity index 86% rename from src/lib/mod_tools_infile.f90 rename to app/mod_tools_infile.f90 index ae8661b..ddc8c43 100644 --- a/src/lib/mod_tools_infile.f90 +++ b/app/mod_tools_infile.f90 @@ -8,7 +8,7 @@ !!! val (outputs contents of string occuring after "=") !!! getline (gets the line using grep and goes back to start of line) !!! assignI (assign an integer to variable) -!!! assignD (assign a double precision to variable) +!!! assignD (assign a real(real32) to variable) !!! assignIvec (assign an arbitrary length vector of integers to variable) !!! assignDvec (assign an arbitrary length vector of DP to variable) !!! assignS (assign a string to variable) @@ -19,14 +19,15 @@ !!! cat (cat lines until user-defined end string is encountered) !!!############################################################################# module infile_tools - use misc, only: grep,icount + use artemis__constants, only: real32 + use artemis__misc, only: grep,icount implicit none interface assign - procedure assignI,assignR,assignD,assignS,assignL + procedure assignI,assignR,assignS,assignL end interface assign interface assign_vec - procedure assignIvec,assignRvec,assignDvec + procedure assignIvec,assignRvec end interface assign_vec @@ -97,13 +98,13 @@ end subroutine assignIvec !!!############################################################################# -!!! assigns a real value to variable if the line contains the right keyword +!!! assigns a DP value to variable if the line contains the right keyword !!!############################################################################# subroutine assignR(buffer,variable,found) integer :: found character(1024) :: buffer1,buffer2 character(*) :: buffer - real :: variable + real(real32) :: variable buffer1=buffer(:scan(buffer,"=")-1) if(scan("=",buffer).ne.0) buffer2=val(buffer) if(trim(adjustl(buffer2)).ne.'') then @@ -121,7 +122,7 @@ subroutine assignRvec(buffer,variable,found) integer :: found,i character(1024) :: buffer1,buffer2 character(*) :: buffer - real, dimension(:) :: variable + real(real32), dimension(:) :: variable buffer1=buffer(:scan(buffer,"=")-1) if(scan("=",buffer).ne.0) buffer2=val(buffer) if(trim(adjustl(buffer2)).ne.'') then @@ -132,42 +133,6 @@ end subroutine assignRvec !!!############################################################################# -!!!############################################################################# -!!! assigns a DP value to variable if the line contains the right keyword -!!!############################################################################# - subroutine assignD(buffer,variable,found) - integer :: found - character(1024) :: buffer1,buffer2 - character(*) :: buffer - double precision :: variable - buffer1=buffer(:scan(buffer,"=")-1) - if(scan("=",buffer).ne.0) buffer2=val(buffer) - if(trim(adjustl(buffer2)).ne.'') then - found=found+1 - read(buffer2,*) variable - end if - end subroutine assignD -!!!############################################################################# - - -!!!############################################################################# -!!! assigns a DP value to variable -!!!############################################################################# - subroutine assignDvec(buffer,variable,found) - integer :: found,i - character(1024) :: buffer1,buffer2 - character(*) :: buffer - double precision, dimension(:) :: variable - buffer1=buffer(:scan(buffer,"=")-1) - if(scan("=",buffer).ne.0) buffer2=val(buffer) - if(trim(adjustl(buffer2)).ne.'') then - found=found+1 - read(buffer2,*) (variable(i),i=1,size(variable)) - end if - end subroutine assignDvec -!!!############################################################################# - - !!!############################################################################# !!! assigns a string !!!############################################################################# @@ -219,7 +184,7 @@ end subroutine assignL function assign_list(buffer,tag_list,num) result(var) implicit none integer :: nlist,loc2,i - double precision :: var + real(real32) :: var character(len=1024) :: new_buffer integer, allocatable, dimension(:) :: loc_list integer, intent(in) :: num @@ -256,7 +221,7 @@ end function assign_list function assign_listvec(buffer,tag_list,num) result(var) implicit none integer :: nlist,loc2,i - double precision, allocatable, dimension(:) :: var + real(real32), allocatable, dimension(:) :: var character(len=1024) :: new_buffer integer, allocatable, dimension(:) :: loc_list integer, intent(in) :: num @@ -302,7 +267,7 @@ subroutine rm_comments(buffer,itmp) lbracket=scan(buffer,'(',back=.true.) rbracket=scan(buffer(lbracket:),')') if(lbracket.eq.0.or.rbracket.eq.0)then - write(6,'(A,I0)') & + write(*,'(A,I0)') & ' NOTE: a bracketing error was encountered on line ',iline buffer="" return diff --git a/docs/ARTEMIS.bib b/docs/ARTEMIS.bib new file mode 100644 index 0000000..5be1b5c --- /dev/null +++ b/docs/ARTEMIS.bib @@ -0,0 +1,12 @@ +@article{Taylor2020ARTEMISAbInitioRestructuring, + title = {{ARTEMIS: Ab initio restructuring tool enabling the modelling of interface structures}}, + year = {2020}, + journal = {Computer Physics Communications}, + author = {Taylor, Ned Thaddeus and Davies, Francis Huw and Rudkin, Isiah Edward Mikel and Price, Conor Jason and Chan, Tsz Hin and Hepplestone, Steven Paul}, + month = {12}, + pages = {107515}, + volume = {257}, + url = {https://linkinghub.elsevier.com/retrieve/pii/S0010465520302423}, + doi = {10.1016/j.cpc.2020.107515}, + issn = {00104655} +} diff --git a/docs/Cc-by-nc_icon.png b/docs/Cc-by-nc_icon.png deleted file mode 100644 index 080b787..0000000 Binary files a/docs/Cc-by-nc_icon.png and /dev/null differ diff --git a/docs/Makefile b/docs/Makefile new file mode 100644 index 0000000..99abc40 --- /dev/null +++ b/docs/Makefile @@ -0,0 +1,20 @@ +# Minimal makefile for Sphinx documentation +# + +# You can set these variables from the command line, and also +# from the environment for the first two. +SPHINXOPTS ?= +SPHINXBUILD ?= python -m sphinx +SOURCEDIR = source +BUILDDIR = build + +# Put it first so that "make" without argument is like "make help". +help: + @$(SPHINXBUILD) -M help "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) + +.PHONY: help Makefile + +# Catch-all target: route all unknown targets to Sphinx using the new +# "make mode" option. $(O) is meant as a shortcut for $(SPHINXOPTS). +%: Makefile + @$(SPHINXBUILD) -M $@ "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) diff --git a/docs/make.bat b/docs/make.bat new file mode 100644 index 0000000..dc1312a --- /dev/null +++ b/docs/make.bat @@ -0,0 +1,35 @@ +@ECHO OFF + +pushd %~dp0 + +REM Command file for Sphinx documentation + +if "%SPHINXBUILD%" == "" ( + set SPHINXBUILD=sphinx-build +) +set SOURCEDIR=source +set BUILDDIR=build + +%SPHINXBUILD% >NUL 2>NUL +if errorlevel 9009 ( + echo. + echo.The 'sphinx-build' command was not found. Make sure you have Sphinx + echo.installed, then set the SPHINXBUILD environment variable to point + echo.to the full path of the 'sphinx-build' executable. Alternatively you + echo.may add the Sphinx directory to PATH. + echo. + echo.If you don't have Sphinx installed, grab it from + echo.https://www.sphinx-doc.org/ + exit /b 1 +) + +if "%1" == "" goto help + +%SPHINXBUILD% -M %1 %SOURCEDIR% %BUILDDIR% %SPHINXOPTS% %O% +goto end + +:help +%SPHINXBUILD% -M help %SOURCEDIR% %BUILDDIR% %SPHINXOPTS% %O% + +:end +popd diff --git a/docs/requirements.txt b/docs/requirements.txt new file mode 100644 index 0000000..050cc9b --- /dev/null +++ b/docs/requirements.txt @@ -0,0 +1,4 @@ +sphinx==8.2.3 +sphinx-rtd-theme==3.0.2 +sphinxcontrib-bibtex==2.6.3 +# f90wrap==0.2.16 diff --git a/docs/artemis_logo.pdf b/docs/source/ARTEMIS_logo.pdf similarity index 100% rename from docs/artemis_logo.pdf rename to docs/source/ARTEMIS_logo.pdf diff --git a/docs/source/ARTEMIS_logo_no_background.png b/docs/source/ARTEMIS_logo_no_background.png new file mode 100644 index 0000000..1100bc9 Binary files /dev/null and b/docs/source/ARTEMIS_logo_no_background.png differ diff --git a/docs/source/about.rst b/docs/source/about.rst new file mode 100644 index 0000000..4e6abce --- /dev/null +++ b/docs/source/about.rst @@ -0,0 +1,14 @@ +.. _about: + +===== +About +===== + + +ARTEMIS (Ab Initio Restructuring Tool Enabling Modelling of Interface Structures) is a package for generating lattice matched interfaces between material. +ARTEMIS interfaces with the `Atomic Simulation Environment (ASE) `_. + +ARTEMIS is both a Fortran and a Python library, with the option of a Fortran executable. +The code heavily relies on features of recent Fortran releases, so there is no backwards compatibility with Fortran95. + +The library enables users to provide two crystal structures, from which it generates a set of lattice matched interfaces within user-defined tolerances. \ No newline at end of file diff --git a/docs/source/artemis.ascii b/docs/source/artemis.ascii new file mode 100644 index 0000000..cd00669 --- /dev/null +++ b/docs/source/artemis.ascii @@ -0,0 +1,33 @@ + + -/+o:` + .hdddy-/o` + ydddddd+ys + :dddddddmo + ++syyyo:+ + .y` oy + +d` dd` + ym` .Nm. + `dN. /Mm. -//:-..` + .mN- yMm. .-:/+osssssssydy. + .mM: `dMm` ./shm/ `oNm/ + .mMo .NMd` `-+sdNds+-` oNm/ + `mMy :MMh`:+ymNhs/. // + dMm` .:dMMMho/. + yMM- ./ohNmyoyMM+ + oMM+ ./sdNmy+:` dMM: + -MMy -/sdNdy+-` `mMN. + `NMm` -/sdNds+- .NMm` + hMMhdNds+- :MMy + `.--:-. -+hMMy/- +MM+ + -://++ooo+//::/smhyo+MMy oMM- +:+::-. `:/++/mh hMd sMm` + `--.. .. .sNo :MN. yMy + `/ :ymo` mN- yM: + domh: +M: ym` + `o/` `m/ ss + +/ /...` + `:+o+:/ .shhhy/+: + :hsss+--s- dhhhhhy/y+ + yssssssood ohhhhhhhhy + .sssssssho /yhhhhdy. + -:/+/:` .-::` diff --git a/docs/source/conf.py b/docs/source/conf.py new file mode 100644 index 0000000..aceb673 --- /dev/null +++ b/docs/source/conf.py @@ -0,0 +1,97 @@ +# Configuration file for the Sphinx documentation builder. + +# -- Project information +import datetime +import os +import sys + +from unittest.mock import Mock + +MOCK_MODULES = ["artemis._artemis"] # List any other modules if needed +sys.modules.update((mod_name, Mock()) for mod_name in MOCK_MODULES) + +sys.path.insert(0, os.path.abspath(os.path.join('..', '..', 'src'))) # Sets the base path to find your modules + +project = 'ARTEMIS' +copyright = f'{datetime.date.today().year}, ARTEMIS-developers' +# release = '1.0' +# version = '1.0.0' + +# -- General configuration +master_doc = 'index' + +# Identify the branch of the documentation +on_rtd = os.environ.get('READTHEDOCS') == 'True' +if on_rtd: + git_branch = os.environ.get("READTHEDOCS_GIT_IDENTIFIER", "main") +else: + git_branch = "main" # or get from git directly with subprocess + +extensions = [ + 'sphinx.ext.duration', + 'sphinx.ext.doctest', + 'sphinx.ext.autodoc', + 'sphinx.ext.autosummary', + 'sphinx.ext.intersphinx', + 'sphinxcontrib.bibtex', + 'sphinx.ext.napoleon', + 'sphinx.ext.viewcode', + 'sphinx_rtd_theme', + 'sphinx.ext.extlinks', +] + +extlinks = { + 'git': ('https://github.com/ExeQuantCode/ARTEMIS/blob/' + git_branch + '/%s', 'git: %s') +} + +intersphinx_mapping = { + 'python': ('https://docs.python.org/3/', None), + 'sphinx': ('https://www.sphinx-doc.org/en/master/', None), +} +intersphinx_disabled_domains = ['std'] + +templates_path = ['_templates'] + +exclude_patterns = ['_build', '.DS_Store', 'build'] + + +# -- Options for HTML output + +html_theme = 'sphinx_rtd_theme' + +# -- Options for EPUB output +epub_show_urls = 'footnote' + +html_logo = "ARTEMIS_logo_no_background.png" +# html_favicon = 'favicon.ico' +html_theme_options = { + 'logo_only': False, + 'prev_next_buttons_location': 'bottom', + 'style_external_links': False, + 'vcs_pageview_mode': '', + # 'style_nav_header_background': 'white', + 'flyout_display': 'hidden', + 'version_selector': True, + 'language_selector': True, + # Toc options + 'collapse_navigation': True, + 'sticky_navigation': True, + 'navigation_depth': 4, + 'includehidden': True, + 'titles_only': False, +} + + +html_context = { + "display_github": True, + "github_repo": "ARTEMIS", + "github_user": "ExeQuantCode", + "github_version": git_branch, + "conf_py_path": "/docs/source/", +} + +html_extra_path = ['/docs/'] + +autoclass_content="both" + +bibtex_bibfiles = ['references.bib'] diff --git a/docs/source/faq.rst b/docs/source/faq.rst new file mode 100644 index 0000000..d3c2293 --- /dev/null +++ b/docs/source/faq.rst @@ -0,0 +1,28 @@ +.. _faq: + +========================== +Frequently Asked Questions +========================== + + +General +======= + +.. _cite: + +How to cite ARTEMIS? +-------------------- + +If you use ARTEMIS in your research, please cite the following paper: + + | Ned Thaddeus Taylor, Francis Huw Davies, + | Isiah Edward Mikel Rudkin, Conor Jason Price, + | Tsz Hin Chan, Steven Paul Hepplestone, + | ARTEMIS: Ab initio restructuring tool enabling the modelling of interface structures, + | Comput. Phys. Commun. Vol. 257 107515, 2020. + | doi: 10.1016/j.cpc.2020.107515 + +BibTex (:git:`bibliography `): + +.. literalinclude:: ../ARTEMIS.bib + \ No newline at end of file diff --git a/docs/source/index.rst b/docs/source/index.rst new file mode 100644 index 0000000..2e9e018 --- /dev/null +++ b/docs/source/index.rst @@ -0,0 +1,67 @@ +======= +ARTEMIS +======= + +ARTEMIS (Ab Initio Restructuring Tool Enabling Modelling of Interface Structures) is a Python and Fortran package for generating lattice matched structured between materials. +ARTEMIS can be utilised as a Python package, a Fortran library, or a standalone Fortran executable. +The Python package provides a high-level interface to the Fortran library, which contains the core functionality. + +The Python package interfaces seemlessly with `ASE (Atomic Simulation Environment) `_, allowing for easy reading, writing, and manipulation of atomic structures. +Although the package comes with a built-in atomic structure reader and writer, it is recommended to use ASE due to its greater functionality and wide-reaching support. + +The code is provided freely available under the `GNU General Public License v3.0 `_. + +An example + +.. code-block:: python + + # A simple example of how to use ARTEMIS to generate lattice matches structures between silicon and germanium and write them to a single file. + from ase import Atoms + from ase.build import bulk + from ase.io import write + from artemis.generator import artemis_generator + from mace.calculators import mace_mp + from ase.calculators.singlepoint import SinglePointCalculator + + generator = artemis_generator() + + calc = mace_mp(model="medium", dispersion=False, default_dtype="float32", device='cpu') + + Si = bulk('Si', 'diamond', a=5.43, cubic=True) + Ge = bulk('Ge', 'diamond', a=5.66, cubic=True) + + generator.set_materials(Si, Ge) + + generator.set_surface_properties( + miller_lw = [ 1, 1, 0 ], + miller_up = [ 1, 1, 0 ], + ) + + structures = generator.generate(calc=calc) + + for structure in structures: + structure.calc = SinglePointCalculator( + structure, + energy=structure.get_potential_energy(), + forces=structure.get_forces() + ) + + write('structures.traj', structures) + +.. toctree:: + :maxdepth: 3 + :caption: Contents: + + about + install + tutorials/index + faq +.. tutorials/index +.. Python API + +.. Indices and tables +.. ================== + +.. * :ref:`genindex` +.. * :ref:`modindex` +.. * :ref:`search` \ No newline at end of file diff --git a/docs/source/install.rst b/docs/source/install.rst new file mode 100644 index 0000000..4b36f5b --- /dev/null +++ b/docs/source/install.rst @@ -0,0 +1,199 @@ +.. _install: + +============ +Installation +============ + +For the Python library, the easiest method of installation is to install it directly from pip: + +.. code-block:: bash + + pip install artemis-materials + +Once this is done, ARTEMIS is ready to be used (both the Python library and the command line interface). + +Alternatively, to install ARTEMIS from source, follow the instructions below. + + +ARTEMIS can be installed in one of three ways; as a Python package, as a Fortran library, or as a standalone Fortran executable. +All versions rely on the core Fortran code, with the Python package and standalone executable wrapping this code in a Python and Fortran interface, respectively. + +The code is hosted on `GitHub `_. + +This can be done by cloning the repository: + +.. code-block:: bash + + git clone https://github.com/ExeQuantCode/artemis.git + cd artemis + +Depending on what language will be used in, installation will vary from this point. + + +Global requirements +=================== + +All installation methods require the following dependency: + +- Fortran compiler (gfortran>=13.1, not compatible with intel compilers) + +Python +====== + +Requirements +------------ + +- python (>=3.11) +- `pip `_ +- `f90wrap `_ (>=0.2.14) +- `numpy `_ (>=1.26) +- `meson `_ (>=1.6) +- `cython `_ (>=3.0) +- `sckit-build-core `_ (>=0.11) +- `cmake `_ (>=3.17) +- `ninja `_ (>=1.10) or `GNU Make `_ +- `ASE `_ (>=3.23) + + +Installation using pip +----------------------- + +The easiest way to install ARTEMIS is via pip. +The package is directly available via PyPI, so can be installed without downloading the repository. To do so, run: + +.. code-block:: bash + + pip install artemis-materials + +This will install the ARTEMIS package and all its dependencies in the default location. +This is the recommended method of installation, as it is the easiest and most straightforward way to get started with ARTEMIS. + +Another option is to install ARTEMIS from the source code, which is recommended if you want to use the latest version of ARTEMIS or if you want to contribute to its development. +To do this, you will need to clone the repository from GitHub. + +Once the library is cloned, navigate to the root directory of the repository and run: + +.. code-block:: bash + + pip install . + +Depending on your setup, this will install the Python package and all its dependencies in different places. +To find where this has been installed, you can run: + +.. code-block:: bash + + pip show artemis-materials + +This will show you the location of the installed package, in addition to other information about the package. + +Installation using cmake +------------------------ + +Another option is installing it through cmake, which involves: +.. code-block:: bash + + mkdir build + cd build + cmake .. + make install + +Then, the path to the install directory (`${HOME}/.local/artemis`) needs to be added to the include path. +NOTE: this method requires that the user manually installs the `ase`, `numpy` and `f90wrap` modules for Python. + +Fortran +======= + +Requirements +------------ + +- `cmake `_ (>=3.17) or `fpm `_ (>=0.9.0) +- `GNU Make `_ (if using cmake) + + +As mentioned, the Fortran library provides the same functionality as the Python package, but in Fortran instead. + +To install the Fortran library or executable, the recommended method is to use the Fortran package manager (fpm). +Cmake is also supported. + +Installation using fpm +---------------------- + +To install the Fortran library and the executable using fpm, navigate to the root directory of the repository and run: + +.. code-block:: bash + + fpm build --profile release + fpm install + +This can also be set up as a dependency in your own fpm project by adding the following to your ``fpm.toml`` file: + +.. code-block:: toml + + [dependencies] + artemis = { git = "https://github.com/ExeQuantCode/ARTEMIS" } + + +Installation using cmake +------------------------ + +To install the Fortran library using cmake, navigate to the root directory of the repository and run: + +.. code-block:: bash + + mkdir build + cd build + cmake -DBUILD_PYTHON=Off -DBUILD_EXECUTABLE=Off .. + make + make install + +This will build the Fortran library and install it in the default location (``~/.local/artemis``). + +To install the standalone executable, run: + +.. code-block:: bash + + mkdir build + cd build + cmake -DBUILD_PYTHON=Off -DBUILD_EXECUTABLE=On .. + make + make install + +This will build the Fortran library and install it in the default location (``~/.local/artemis``). + + +Installing on MacOS (Homebrew) +============================== + +ARTEMIS is developed on Linux and MacOS, and should work on both. +However, there are likely some additional steps required to install ARTEMIS on MacOS. +This is because **it is not recommended to rely on the Mac system Python, or Fortran and C compilers**. + +The recommended way to install Python, gfortran and gcc on MacOS is to use `Homebrew `_. +First, install Homebrew by following the guide on their website. + +Once Homebrew is installed, you can install the required dependencies by running: + +.. code-block:: bash + + brew install python + brew install gcc + brew install gfortran + export CC=$(brew --prefix gfortran) + export FC=$(brew --prefix gcc) + +Confirm a successful Python installation by running: + +.. code-block:: bash + + python --version + whereis python + +This should show the correct Python version (3.11 or later) and path. + +Next, if you are using ``pip``, then the following command is found to result in the least issues: + +.. code-block:: bash + + python -m pip install --upgrade . + +This ensures that the correct Python version is being called, and that the correct version of ``pip`` is being used. diff --git a/docs/source/references.bib b/docs/source/references.bib new file mode 100644 index 0000000..f2c31a0 --- /dev/null +++ b/docs/source/references.bib @@ -0,0 +1,30 @@ +@article{ase-paper, + author={Ask Hjorth Larsen and Jens Jørgen Mortensen and Jakob Blomqvist and Ivano E Castelli and Rune Christensen and Marcin +Dułak and Jesper Friis and Michael N Groves and Bjørk Hammer and Cory Hargus and Eric D Hermes and Paul C Jennings and Peter +Bjerre Jensen and James Kermode and John R Kitchin and Esben Leonhard Kolsbjerg and Joseph Kubal and Kristen +Kaasbjerg and Steen Lysgaard and Jón Bergmann Maronsson and Tristan Maxson and Thomas Olsen and Lars Pastewka and Andrew +Peterson and Carsten Rostgaard and Jakob Schiøtz and Ole Schütt and Mikkel Strange and Kristian S Thygesen and Tejs +Vegge and Lasse Vilhelmsen and Michael Walter and Zhenhua Zeng and Karsten W Jacobsen}, + title={The atomic simulation environment—a Python library for working with atoms}, + journal={Journal of Physics: Condensed Matter}, + volume={29}, + number={27}, + pages={273002}, + url={http://stacks.iop.org/0953-8984/29/i=27/a=273002}, + year={2017}, + abstract={The atomic simulation environment (ASE) is a software package written in the Python programming language with the aim of setting up, steering, and analyzing atomistic simulations. In ASE, tasks are fully scripted in Python. The powerful syntax of Python combined with the NumPy array library make it possible to perform very complex simulation tasks. For example, a sequence of calculations may be performed with the use of a simple ‘for-loop’ construction. Calculations of energy, forces, stresses and other quantities are performed through interfaces to many external electronic structure codes or force fields using a uniform interface. On top of this calculator interface, ASE provides modules for performing many standard simulation tasks such as structure optimization, molecular dynamics, handling of constraints and performing nudged elastic band calculations.} +} + +@article{Jain2013CommentaryMaterialsProject, + title = {Commentary: The Materials Project: A materials genome approach to accelerating materials innovation}, + volume = {1}, + ISSN = {2166-532X}, + url = {http://dx.doi.org/10.1063/1.4812323}, + DOI = {10.1063/1.4812323}, + number = {1}, + journal = {APL Materials}, + publisher = {AIP Publishing}, + author = {Jain, Anubhav and Ong, Shyue Ping and Hautier, Geoffroy and Chen, Wei and Richards, William Davidson and Dacek, Stephen and Cholia, Shreyas and Gunter, Dan and Skinner, David and Ceder, Gerbrand and Persson, Kristin A.}, + year = {2013}, + month = jul +} diff --git a/docs/source/tutorials/identify_interface_tutorial.rst b/docs/source/tutorials/identify_interface_tutorial.rst new file mode 100644 index 0000000..0c7d273 --- /dev/null +++ b/docs/source/tutorials/identify_interface_tutorial.rst @@ -0,0 +1,36 @@ +.. identify_interface: + +================== +Identify interface +================== + +This tutorial demonstrates how to use the ARTEMIS library to return the interface location in an interface structure. + + +The following code snippet shows how to use ARTEMIS to identify the interface location in a structure. + + +.. code-block:: python + + # Import the necessary libraries + from ase.io import read + from artemis.generator import artemis_generator + + # Read the interface structure from a file + atoms = read("interface.xyz") + + # Initialise the ARTEMIS generator + generator = artemis_generator() + + # Get the interface location and axis using ARTEMIS + location, axis = generator.get_interface_location(atoms, return_fractional=True) + print("location", location) + print("axis", axis) + +The interface location is returned as a single value, which is the distance from the origin of the structure to the interface in the direction of the returned axis. +The axis is an integer specifying the direction of the interface in the structure (i.e. 0, 1, or 2 for a, b, or c respectively). + +The `return_fractional` argument specifies whether to return the interface location in fractional coordinates (True) or in Cartesian coordinates (False). +The default value is False. + +This can then be used in conjunction with `RAFFLE `_ to reconfigure atoms near to the interface to search for more stable configurations. diff --git a/docs/source/tutorials/index.rst b/docs/source/tutorials/index.rst new file mode 100644 index 0000000..e9477cd --- /dev/null +++ b/docs/source/tutorials/index.rst @@ -0,0 +1,26 @@ +.. tutorials: + +========= +Tutorials +========= + +The tutorials are designed to help you get started with ARTEMIS. +They cover the parameters and options available in ARTEMIS, as well as the basic usage of the library. + +.. note:: + + These tutorials are currently focused on the Python interface. + The command line interface is documented in the :git:`manual `, in addition to its help and search arguments. + +.. toctree:: + :maxdepth: 2 + :caption: Setup and parameters: + + parameters_tutorial + +.. toctree:: + :maxdepth: 2 + :caption: Post-processing: + + identify_interface_tutorial + diff --git a/docs/source/tutorials/parameters_tutorial.rst b/docs/source/tutorials/parameters_tutorial.rst new file mode 100644 index 0000000..57b8bc8 --- /dev/null +++ b/docs/source/tutorials/parameters_tutorial.rst @@ -0,0 +1,135 @@ +.. parameters: + +================== +Setting parameters +================== + +This tutorial will detail how to initialise an ARTEMIS generator. +It will also explore the parameters associated with the lattice matching and interface alignment methods used by ARTEMIS, in addition to its surface termination identification parameters. + +Initialisation +-------------- +ARTEMIS is initialised by importing the generator object. +The object is the main interface for the user to interact with ARTEMIS. + +.. code-block:: python + + # Initialise ARTEMIS generator + from artemis.generator import artemis_generator + + generator = artemis_generator() + +It is recommended to use the Atomic Simulation Environment (ASE) :footcite:t:`ase-paper` for handling structure data. +Whilst ARTEMIS can handle its own atomic structure object, ASE is more widely used and has a more extensive feature set. + + +Constituent structures +---------------------- + +The first step in using ARTEMIS is to define the constituent structures. +The generator object has a method called ``set_materials`` which takes a list of ASE atoms objects. + +.. code-block:: python + + from ase.build import bulk + + # Define the constituent structures + Si = bulk('Si', 'diamond', a=5.43, cubic=True) + Ge = bulk('Ge', 'diamond', a=5.66, cubic=True) + + generator.set_materials(Si, Ge) + +The above code defines two bulk structures, silicon and germanium, and sets them as the constituent structures for the generator object. +This method can also be used to define the elastic constants of the constituent structures and define whether to identify and use the primitive cell for each structure. +These can be accessed by the following parameters: + +.. code-block:: python + + # Set the elastic constants and primitive cell usage + generator.set_materials( + structure_lw=Si, + structure_up=Ge, + elastic_lw=6, + elastic_up=12, + use_pricel_lw=True, + use_pricel_up=True + ) + +The elastic constants are currently isotropic bulks moduli. +The elastic constants can be calculated using ASE or obtained from the literature, such as the Materials Project :footcite:t:`Jain2013CommentaryMaterialsProject`. +The primitive cell usage is a boolean value that indicates whether to use the primitive cell of the structure or not. + + +Surface properties +------------------ + +The next step is to define the surface properties of the interface. +The generator object has a method called ``set_surface_properties`` which takes the Miller indices of the surface planes to be used. +If no Miller indices are provided, the generator will search over the 10 lowest symmetry planes. + +.. code-block:: python + + # Define the surface properties + generator.set_surface_properties( + miller_lw=[1, 1, 0], + miller_up=[1, 1, 0] + ) + +The above code sets the Miller indices of the surface planes to be used for the lower and upper structures. +The Miller indices are a set of three integers that describe the orientation of the surface planes in the crystal lattice. +Additional parameters can be set to define the surface properties, such as: + +.. code-block:: python + + # Set additional surface properties + generator.set_surface_properties( + miller_lw=[1, 1, 0], + miller_up=[1, 1, 0], + is_layered_lw=True, + is_layered_up=True, + require_stoichiometry_lw=True, + require_stoichiometry_up=True, + layer_separation_cutoff_lw=0.5, + layer_separation_cutoff_up=0.5, + ) + +The above code sets the following additional parameters: +- ``is_layered_lw`` and ``is_layered_up``: boolean values that indicate whether the lower and upper structures are to be treated as layered or not. +- ``require_stoichiometry_lw`` and ``require_stoichiometry_up``: boolean values that indicate whether the generated lower and upper slabs should be stoichiometrically equivalent to their respective provided structures. +- ``layer_separation_cutoff_lw`` and ``layer_separation_cutoff_up``: float values that define the cutoff distance for the minimally accepted layer separation (in Angstroms) with which to define distinct planes of atoms. + + +The following are optional parameters that can be set for the generator. + +Tolerance parameters +-------------------- + +Tolerances constraining returned structures can be set using the ``set_tolerance`` method. +These tolerances are mostly related to lattice matching. + +.. code-block:: python + + # Set the tolerance parameters + generator.set_tolerance( + vector_mismatch=0.1, + angle_mismatch=0.1, + max_length=0.1, + max_area=0.1, + max_fit=2, + max_extension=2 + ) + + +Lattice matching parameters +--------------------------- + +The generator object has a method called ``set_match_method`` to set the parameters for the lattice matching method. + + +Interface alignment parameters +------------------------------ + +For interface alignment, the generator can be used to provide a single permutation, or a set of permutations for efficient searching. +The generator object has a method called ``set_shift_method`` which takes the following parameters: + +.. footbibliography:: diff --git a/examples/generate_interface/DINTERFACES/D01/DSHIFT/D01/DSWAP/D01/POSCAR b/example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D01/DSWAP/D01/POSCAR similarity index 100% rename from examples/generate_interface/DINTERFACES/D01/DSHIFT/D01/DSWAP/D01/POSCAR rename to example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D01/DSWAP/D01/POSCAR diff --git a/examples/generate_interface/DINTERFACES/D01/DSHIFT/D01/DSWAP/D02/POSCAR b/example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D01/DSWAP/D02/POSCAR similarity index 100% rename from examples/generate_interface/DINTERFACES/D01/DSHIFT/D01/DSWAP/D02/POSCAR rename to example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D01/DSWAP/D02/POSCAR diff --git a/examples/generate_interface/DINTERFACES/D01/DSHIFT/D01/DSWAP/D03/POSCAR b/example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D01/DSWAP/D03/POSCAR similarity index 100% rename from examples/generate_interface/DINTERFACES/D01/DSHIFT/D01/DSWAP/D03/POSCAR rename to example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D01/DSWAP/D03/POSCAR diff --git a/examples/generate_interface/DINTERFACES/D01/DSHIFT/D01/DSWAP/D04/POSCAR b/example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D01/DSWAP/D04/POSCAR similarity index 100% rename from examples/generate_interface/DINTERFACES/D01/DSHIFT/D01/DSWAP/D04/POSCAR rename to example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D01/DSWAP/D04/POSCAR diff --git a/examples/generate_interface/DINTERFACES/D01/DSHIFT/D01/DSWAP/D05/POSCAR b/example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D01/DSWAP/D05/POSCAR similarity index 100% rename from examples/generate_interface/DINTERFACES/D01/DSHIFT/D01/DSWAP/D05/POSCAR rename to example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D01/DSWAP/D05/POSCAR diff --git a/examples/generate_interface/DINTERFACES/D01/DSHIFT/D01/POSCAR b/example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D01/POSCAR similarity index 100% rename from examples/generate_interface/DINTERFACES/D01/DSHIFT/D01/POSCAR rename to example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D01/POSCAR diff --git a/examples/generate_interface/DINTERFACES/D01/DSHIFT/D02/DSWAP/D01/POSCAR b/example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D02/DSWAP/D01/POSCAR similarity index 100% rename from examples/generate_interface/DINTERFACES/D01/DSHIFT/D02/DSWAP/D01/POSCAR rename to example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D02/DSWAP/D01/POSCAR diff --git a/examples/generate_interface/DINTERFACES/D01/DSHIFT/D02/DSWAP/D02/POSCAR b/example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D02/DSWAP/D02/POSCAR similarity index 100% rename from examples/generate_interface/DINTERFACES/D01/DSHIFT/D02/DSWAP/D02/POSCAR rename to example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D02/DSWAP/D02/POSCAR diff --git a/examples/generate_interface/DINTERFACES/D01/DSHIFT/D02/DSWAP/D03/POSCAR b/example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D02/DSWAP/D03/POSCAR similarity index 100% rename from examples/generate_interface/DINTERFACES/D01/DSHIFT/D02/DSWAP/D03/POSCAR rename to example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D02/DSWAP/D03/POSCAR diff --git a/examples/generate_interface/DINTERFACES/D01/DSHIFT/D02/DSWAP/D04/POSCAR b/example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D02/DSWAP/D04/POSCAR similarity index 100% rename from examples/generate_interface/DINTERFACES/D01/DSHIFT/D02/DSWAP/D04/POSCAR rename to example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D02/DSWAP/D04/POSCAR diff --git a/examples/generate_interface/DINTERFACES/D01/DSHIFT/D02/DSWAP/D05/POSCAR b/example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D02/DSWAP/D05/POSCAR similarity index 100% rename from examples/generate_interface/DINTERFACES/D01/DSHIFT/D02/DSWAP/D05/POSCAR rename to example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D02/DSWAP/D05/POSCAR diff --git a/examples/generate_interface/DINTERFACES/D01/DSHIFT/D02/POSCAR b/example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D02/POSCAR similarity index 100% rename from examples/generate_interface/DINTERFACES/D01/DSHIFT/D02/POSCAR rename to example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D02/POSCAR diff --git a/examples/generate_interface/DINTERFACES/D01/DSHIFT/D03/DSWAP/D01/POSCAR b/example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D03/DSWAP/D01/POSCAR similarity index 100% rename from examples/generate_interface/DINTERFACES/D01/DSHIFT/D03/DSWAP/D01/POSCAR rename to example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D03/DSWAP/D01/POSCAR diff --git a/examples/generate_interface/DINTERFACES/D01/DSHIFT/D03/DSWAP/D02/POSCAR b/example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D03/DSWAP/D02/POSCAR similarity index 100% rename from examples/generate_interface/DINTERFACES/D01/DSHIFT/D03/DSWAP/D02/POSCAR rename to example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D03/DSWAP/D02/POSCAR diff --git a/examples/generate_interface/DINTERFACES/D01/DSHIFT/D03/DSWAP/D03/POSCAR b/example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D03/DSWAP/D03/POSCAR similarity index 100% rename from examples/generate_interface/DINTERFACES/D01/DSHIFT/D03/DSWAP/D03/POSCAR rename to example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D03/DSWAP/D03/POSCAR diff --git a/examples/generate_interface/DINTERFACES/D01/DSHIFT/D03/DSWAP/D04/POSCAR b/example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D03/DSWAP/D04/POSCAR similarity index 100% rename from examples/generate_interface/DINTERFACES/D01/DSHIFT/D03/DSWAP/D04/POSCAR rename to example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D03/DSWAP/D04/POSCAR diff --git a/examples/generate_interface/DINTERFACES/D01/DSHIFT/D03/DSWAP/D05/POSCAR b/example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D03/DSWAP/D05/POSCAR similarity index 100% rename from examples/generate_interface/DINTERFACES/D01/DSHIFT/D03/DSWAP/D05/POSCAR rename to example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D03/DSWAP/D05/POSCAR diff --git a/examples/generate_interface/DINTERFACES/D01/DSHIFT/D03/POSCAR b/example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D03/POSCAR similarity index 100% rename from examples/generate_interface/DINTERFACES/D01/DSHIFT/D03/POSCAR rename to example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D03/POSCAR diff --git a/examples/generate_interface/DINTERFACES/D01/DSHIFT/D04/DSWAP/D01/POSCAR b/example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D04/DSWAP/D01/POSCAR similarity index 100% rename from examples/generate_interface/DINTERFACES/D01/DSHIFT/D04/DSWAP/D01/POSCAR rename to example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D04/DSWAP/D01/POSCAR diff --git a/examples/generate_interface/DINTERFACES/D01/DSHIFT/D04/DSWAP/D02/POSCAR b/example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D04/DSWAP/D02/POSCAR similarity index 100% rename from examples/generate_interface/DINTERFACES/D01/DSHIFT/D04/DSWAP/D02/POSCAR rename to example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D04/DSWAP/D02/POSCAR diff --git a/examples/generate_interface/DINTERFACES/D01/DSHIFT/D04/DSWAP/D03/POSCAR b/example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D04/DSWAP/D03/POSCAR similarity index 100% rename from examples/generate_interface/DINTERFACES/D01/DSHIFT/D04/DSWAP/D03/POSCAR rename to example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D04/DSWAP/D03/POSCAR diff --git a/examples/generate_interface/DINTERFACES/D01/DSHIFT/D04/DSWAP/D04/POSCAR b/example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D04/DSWAP/D04/POSCAR similarity index 100% rename from examples/generate_interface/DINTERFACES/D01/DSHIFT/D04/DSWAP/D04/POSCAR rename to example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D04/DSWAP/D04/POSCAR diff --git a/examples/generate_interface/DINTERFACES/D01/DSHIFT/D04/DSWAP/D05/POSCAR b/example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D04/DSWAP/D05/POSCAR similarity index 100% rename from examples/generate_interface/DINTERFACES/D01/DSHIFT/D04/DSWAP/D05/POSCAR rename to example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D04/DSWAP/D05/POSCAR diff --git a/examples/generate_interface/DINTERFACES/D01/DSHIFT/D04/POSCAR b/example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D04/POSCAR similarity index 100% rename from examples/generate_interface/DINTERFACES/D01/DSHIFT/D04/POSCAR rename to example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D04/POSCAR diff --git a/examples/generate_interface/DINTERFACES/D01/DSHIFT/D05/POSCAR b/example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D05/POSCAR similarity index 100% rename from examples/generate_interface/DINTERFACES/D01/DSHIFT/D05/POSCAR rename to example/fortran_exe/generate_interface/DINTERFACES/D01/DSHIFT/D05/POSCAR diff --git a/example/fortran_exe/generate_interface/DINTERFACES/settings.txt b/example/fortran_exe/generate_interface/DINTERFACES/settings.txt new file mode 100644 index 0000000..47530f3 --- /dev/null +++ b/example/fortran_exe/generate_interface/DINTERFACES/settings.txt @@ -0,0 +1,35 @@ +SETTINGS + TASK = 1 + RESTART = 0 + CLOCK = 972499989 +END SETTINGS + + +INTERFACES + LGEN_INTERFACES = T + NINTF = 100 + IMATCH = 0 + NMATCH = 1 + TOL_VEC = 5.0000000 + TOL_ANG = 1.0000000 + TOL_AREA = 10.0000000 + + NMILLER = 10 + LW_MILLER_PLANE = 0 0 0 + UP_MILLER_PLANE = 0 0 0 + LW_SLAB_THICKNESS = 6 + UP_SLAB_THICKNESS = 6 + NTERM = 5 + + ISHIFT = 4 + NSHIFT = 5 + C_SCALE = 1.0000000 + + ISWAP = 2 + NSWAP = 5 + SWAP_DENSITY = .05000 + + LSURF_GEN = F +END INTERFACES + + diff --git a/examples/generate_interface/POSCAR_Ge b/example/fortran_exe/generate_interface/POSCAR_Ge similarity index 100% rename from examples/generate_interface/POSCAR_Ge rename to example/fortran_exe/generate_interface/POSCAR_Ge diff --git a/examples/generate_interface/POSCAR_Si b/example/fortran_exe/generate_interface/POSCAR_Si similarity index 100% rename from examples/generate_interface/POSCAR_Si rename to example/fortran_exe/generate_interface/POSCAR_Si diff --git a/tests/generate_interface/param.in b/example/fortran_exe/generate_interface/param.in similarity index 99% rename from tests/generate_interface/param.in rename to example/fortran_exe/generate_interface/param.in index bb28722..f4ec892 100644 --- a/tests/generate_interface/param.in +++ b/example/fortran_exe/generate_interface/param.in @@ -3,7 +3,7 @@ SETTINGS RESTART = 0 STRUC1_FILE = POSCAR_Si ! lower structure/interface structure STRUC2_FILE = POSCAR_Ge ! upper structure (not used if IRESTART > 0) - IPRINT = -1 + IPRINT = 0 TOL_SYM = 1.D-4 CLOCK = 0 END SETTINGS diff --git a/examples/identify_terminations/DTERMINATIONS/DLW_TERMS/POSCAR_term1 b/example/fortran_exe/identify_terminations/DTERMINATIONS/DLW_TERMS/POSCAR_term1 similarity index 100% rename from examples/identify_terminations/DTERMINATIONS/DLW_TERMS/POSCAR_term1 rename to example/fortran_exe/identify_terminations/DTERMINATIONS/DLW_TERMS/POSCAR_term1 diff --git a/examples/identify_terminations/POSCAR b/example/fortran_exe/identify_terminations/POSCAR similarity index 100% rename from examples/identify_terminations/POSCAR rename to example/fortran_exe/identify_terminations/POSCAR diff --git a/examples/identify_terminations/param.in b/example/fortran_exe/identify_terminations/param.in similarity index 100% rename from examples/identify_terminations/param.in rename to example/fortran_exe/identify_terminations/param.in diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D01/DSWAP/D01/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D01/DSWAP/D01/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D01/DSWAP/D01/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D01/DSWAP/D01/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D01/DSWAP/D02/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D01/DSWAP/D02/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D01/DSWAP/D02/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D01/DSWAP/D02/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D01/DSWAP/D03/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D01/DSWAP/D03/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D01/DSWAP/D03/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D01/DSWAP/D03/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D01/DSWAP/D04/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D01/DSWAP/D04/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D01/DSWAP/D04/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D01/DSWAP/D04/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D01/DSWAP/D05/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D01/DSWAP/D05/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D01/DSWAP/D05/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D01/DSWAP/D05/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D01/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D01/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D01/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D01/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D02/DSWAP/D01/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D02/DSWAP/D01/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D02/DSWAP/D01/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D02/DSWAP/D01/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D02/DSWAP/D02/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D02/DSWAP/D02/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D02/DSWAP/D02/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D02/DSWAP/D02/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D02/DSWAP/D03/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D02/DSWAP/D03/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D02/DSWAP/D03/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D02/DSWAP/D03/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D02/DSWAP/D04/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D02/DSWAP/D04/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D02/DSWAP/D04/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D02/DSWAP/D04/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D02/DSWAP/D05/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D02/DSWAP/D05/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D02/DSWAP/D05/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D02/DSWAP/D05/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D02/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D02/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D02/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D02/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D03/DSWAP/D01/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D03/DSWAP/D01/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D03/DSWAP/D01/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D03/DSWAP/D01/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D03/DSWAP/D02/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D03/DSWAP/D02/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D03/DSWAP/D02/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D03/DSWAP/D02/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D03/DSWAP/D03/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D03/DSWAP/D03/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D03/DSWAP/D03/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D03/DSWAP/D03/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D03/DSWAP/D04/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D03/DSWAP/D04/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D03/DSWAP/D04/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D03/DSWAP/D04/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D03/DSWAP/D05/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D03/DSWAP/D05/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D03/DSWAP/D05/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D03/DSWAP/D05/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D03/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D03/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D03/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D03/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D04/DSWAP/D01/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D04/DSWAP/D01/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D04/DSWAP/D01/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D04/DSWAP/D01/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D04/DSWAP/D02/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D04/DSWAP/D02/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D04/DSWAP/D02/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D04/DSWAP/D02/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D04/DSWAP/D03/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D04/DSWAP/D03/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D04/DSWAP/D03/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D04/DSWAP/D03/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D04/DSWAP/D04/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D04/DSWAP/D04/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D04/DSWAP/D04/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D04/DSWAP/D04/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D04/DSWAP/D05/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D04/DSWAP/D05/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D04/DSWAP/D05/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D04/DSWAP/D05/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D04/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D04/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D04/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D04/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D05/DSWAP/D01/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D05/DSWAP/D01/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D05/DSWAP/D01/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D05/DSWAP/D01/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D05/DSWAP/D02/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D05/DSWAP/D02/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D05/DSWAP/D02/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D05/DSWAP/D02/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D05/DSWAP/D03/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D05/DSWAP/D03/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D05/DSWAP/D03/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D05/DSWAP/D03/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D05/DSWAP/D04/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D05/DSWAP/D04/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D05/DSWAP/D04/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D05/DSWAP/D04/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D05/DSWAP/D05/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D05/DSWAP/D05/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D05/DSWAP/D05/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D05/DSWAP/D05/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/DSHIFT/D05/POSCAR b/example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D05/POSCAR similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/DSHIFT/D05/POSCAR rename to example/fortran_exe/pregenerated_interface/DINTERFACES/DSHIFT/D05/POSCAR diff --git a/examples/pregenerated_interface/DINTERFACES/interface_location.dat b/example/fortran_exe/pregenerated_interface/DINTERFACES/interface_location.dat similarity index 100% rename from examples/pregenerated_interface/DINTERFACES/interface_location.dat rename to example/fortran_exe/pregenerated_interface/DINTERFACES/interface_location.dat diff --git a/examples/pregenerated_interface/POSCAR b/example/fortran_exe/pregenerated_interface/POSCAR similarity index 100% rename from examples/pregenerated_interface/POSCAR rename to example/fortran_exe/pregenerated_interface/POSCAR diff --git a/examples/pregenerated_interface/param.in b/example/fortran_exe/pregenerated_interface/param.in similarity index 100% rename from examples/pregenerated_interface/param.in rename to example/fortran_exe/pregenerated_interface/param.in diff --git a/example/python_pkg/ARTEMIS_and_RAFFLE.py b/example/python_pkg/ARTEMIS_and_RAFFLE.py new file mode 100644 index 0000000..8d9935a --- /dev/null +++ b/example/python_pkg/ARTEMIS_and_RAFFLE.py @@ -0,0 +1,32 @@ +from time import sleep +import numpy +from ase.io import read, write +from ase.visualize import view +atoms = read("structures.traj", index=":") +from artemis.generator import artemis_generator +from raffle.generator import raffle_generator +art_gen = artemis_generator() +raff_gen = raffle_generator() +location, axis = art_gen.get_interface_location(atoms[0], return_fractional=True) +print("location", location) +print("axis", axis) +raff_gen.set_host(atoms[0]) + +missing_stoich = raff_gen.prepare_host(interface_location=location, depth=2, location_as_fractional=True)#11.97]) +print("missing_stoich", missing_stoich) +host_1 = raff_gen.get_host() +view(host_1) + +raff_gen.set_host(atoms[0]) + +host_a = raff_gen.get_host() +view(host_a) + +location, axis = art_gen.get_interface_location(atoms[0], return_fractional=False) +print("location", location) +print("axis", axis) +raff_gen.set_host(atoms[0]) +missing_stoich = raff_gen.prepare_host(interface_location=location, depth=3, location_as_fractional=False)#11.97]) +print("missing_stoich", missing_stoich) +host_2 = raff_gen.get_host() +view(host_2) diff --git a/example/python_pkg/Si-Ge.py b/example/python_pkg/Si-Ge.py new file mode 100644 index 0000000..9613519 --- /dev/null +++ b/example/python_pkg/Si-Ge.py @@ -0,0 +1,29 @@ +from ase import Atoms +from ase.build import bulk +from ase.io import write +from artemis.generator import artemis_generator + +generator = artemis_generator() + +Si = bulk('Si', 'diamond', a=5.43, cubic=True) +Ge = bulk('Ge', 'diamond', a=5.66, cubic=True) + +generator.set_materials(Si, Ge) + +generator.set_surface_properties( + miller_lw = [ 1, 1, 0 ], + miller_up = [ 1, 1, 0 ], +) + +generator.set_shift_method(num_shifts = 1) +generator.set_match_method(max_num_matches = 1) +structures = generator.generate(verbose=1)#calc=calc) + + +write('structures.traj', structures) + +output = generator.get_all_structures_data() +print(output) + +output = generator.get_structure_data(0) +print(output) \ No newline at end of file diff --git a/fpm.toml b/fpm.toml new file mode 100644 index 0000000..d5ed3da --- /dev/null +++ b/fpm.toml @@ -0,0 +1,25 @@ +name = "artemis" +version = "2.0.0" +author = "Ned Thaddeus Taylor" +maintainer = "n.t.taylor@exeter.ac.uk" +description = "A Fortran library for generating interface lattice matches" + +[preprocess] +[preprocess.cpp] +suffixes = ["F90", "f90"] + +[library] +source-dir="src/fortran" + +[dependencies] +openmp = "*" + +[fortran] +implicit-typing = false +implicit-external = false +source-form = "free" + +[[executable]] +name="artemis_executable" +source-dir="app" +main="main.f90" diff --git a/kind_map b/kind_map new file mode 100644 index 0000000..e6e5b84 --- /dev/null +++ b/kind_map @@ -0,0 +1,18 @@ +{ + 'real': {'': 'float', + '4': 'float', + '8': 'double', + 'dp': 'double', + 'idp':'double', + 'real32': 'float'}, + 'complex' : {'': 'complex_float', + '8' : 'complex_double', + '16': 'complex_long_double', + 'dp': 'complex_double', + 'real32': 'complex_float'}, + 'integer' : {'' : 'int', + '4': 'int', + '8': 'long_long', + 'dp': 'long_long', + 'quadint_k': 'long_long'} +} diff --git a/pyproject.toml b/pyproject.toml new file mode 100644 index 0000000..abf21a7 --- /dev/null +++ b/pyproject.toml @@ -0,0 +1,79 @@ +[build-system] +requires = [ + "f90wrap>=0.2.14,<=0.2.16", + "numpy>=1.26.4,<=2.2", + "meson~=1.6.0", + "cython~=3.0.11", + "scikit-build-core", +] +build-backend = "scikit_build_core.build" + +[tool.scikit-build] +cmake.version = "CMakeLists.txt" +ninja.version = ">=1.10" +cmake.build-type = "Release" +cmake.source-dir = "." +cmake.args = [ + "-DBUILD_PYTHON=On", + "-DBUILD_EXECUTABLE=On", + "-DREMAKE_F90WRAP=Off", +] +sdist.cmake = true +wheel.cmake = true +build-dir="build/{wheel_tag}" +wheel.expand-macos-universal-tags = true +ninja.make-fallback = true +sdist.reproducible = true +# dev purposes only +build.verbose = false +wheel.packages = ["src/artemis"] + +[project] +name = "artemis-materials" +dynamic = ["version"] +dependencies = [ + "numpy>=1.26.4,<=2.2", + "f90wrap>=0.2.14,<=0.2.16", +] +requires-python = ">=3.11,<3.14" +authors = [ + { name = "Ned Thaddeus Taylor", email = "n.t.taylor@exeter.ac.uk" }, + { name = "Steven Paul Hepplestone", email = "s.p.hepplestone@exeter.ac.uk" }, +] +description = "A material interface lattice match generator package" +readme = "README.md" +license = { text = 'GNU General Public License v3.0 or later'} +classifiers = [ + "Development Status :: 4 - Beta", + "Intended Audience :: Science/Research", + "Programming Language :: Python :: 3.11", + "Programming Language :: Python :: 3.12", + "Programming Language :: Python :: 3.13", + "Programming Language :: Fortran", + "License :: OSI Approved :: GNU General Public License v3 (GPLv3)", + "Operating System :: OS Independent", +] + +[project.scripts] +artemis = 'artemis.cli.main:main' + +[project.urls] +Homepage = "https://github.com/ExeQuantCode/artemis" +Documentation = "https://artemis-materials.readthedocs.io/" +Repository = "https://github.com/ExeQuantCode/artemis" +Issues = "https://github.com/ExeQuantCode/artemis/issues" + +[project.optional-dependencies] +ase = ["ase>=3.23.0"] +no-ase = [] +tests = [ + "pytest", + "pytest-cov", + "parameterized", + "unittest", +] + +[tool.scikit-build.metadata.version] +provider = "scikit_build_core.metadata.regex" +input = "fpm.toml" +regex = '(?i)^version *= \"(?P.+?)\"' diff --git a/src/artemis/__init__.py b/src/artemis/__init__.py new file mode 100644 index 0000000..90ebfc8 --- /dev/null +++ b/src/artemis/__init__.py @@ -0,0 +1,53 @@ +""" +artemis package + +This package provides functionality to interface with a Fortran library, +including a Python wrapper around the Fortran code. +""" + +from importlib.metadata import PackageNotFoundError, version +try: + __version__ = version(__name__) +except PackageNotFoundError: + __version__ = "unknown" + +from .artemis import generator as _generator_class +from .artemis import geom_rw as _geom_rw_class +# from .artemis import generator + + +# Use the 'types' module to create simulated 'generator' and 'geom submodules +import types +generator = types.ModuleType('generator') +geom = types.ModuleType('geom') + +# Assign the respective class to the simulated 'generator' and 'geom' modules +generator.artemis_generator = _generator_class.artemis_generator + +# Assign the class to the simulated 'geom' module +geom.basis_array = _geom_rw_class.basis_array +geom.basis = _geom_rw_class.basis + + +# Add the simulated 'generator' and 'geom' module to the current package +import sys +sys.modules['artemis.generator'] = generator +sys.modules['artemis.geom'] = geom + +# Clean up internal imports (remove access to the direct classes) +del _generator_class +del _geom_rw_class +del PackageNotFoundError +del version +del sys +del types +del artemis + +__all__ = ['__version__', 'generator', 'geom'] + +def __getattr__(name): + if name == "generator": + return generator + elif name == "geom": + return geom + raise AttributeError(f"module {__name__} has no attribute {name}") \ No newline at end of file diff --git a/src/artemis/artemis.py b/src/artemis/artemis.py new file mode 100644 index 0000000..4ec1207 --- /dev/null +++ b/src/artemis/artemis.py @@ -0,0 +1,2668 @@ +from __future__ import print_function, absolute_import, division +import artemis._artemis as _artemis +import f90wrap.runtime +import logging +import numpy +from ase import Atoms +from typing import Tuple + +class Geom_Rw(f90wrap.runtime.FortranModule): + """ + Code for handling geometry read/write operations. + + This module provides the necessary functionality to read, write, and + store atomic geometries. + In this module, and all of the codebase, element and species are used + interchangeably. + + Defined in ../src/lib/mod_geom_rw.f90 + + .. note:: + It is recommended not to use this module directly, but to handle + atom objects through the ASE interface. + This is provided mostly for compatibility with the existing codebase + and Fortran code. + """ + @f90wrap.runtime.register_class("artemis.species_type") + class species_type(f90wrap.runtime.FortranDerivedType): + def __init__(self, handle=None): + """ + Create a ``species_type`` object. + + Returns: + species (species_type): + Object to be constructed + """ + f90wrap.runtime.FortranDerivedType.__init__(self) + result = _artemis.f90wrap_geom_rw__species_type_initialise() + self._handle = result[0] if isinstance(result, tuple) else result + + def __del__(self): + """ + Destructor for class species_type + + + Defined at ../src/lib/mod_geom_rw.f90 lines \ + 26-32 + + Parameters + ---------- + this : species_type + Object to be destructed + + + Automatically generated destructor for species_type + """ + if self._alloc: + _artemis.f90wrap_geom_rw__species_type_finalise(this=self._handle) + + @property + def atom(self): + """ + Derived type containing the atomic information of a crystal. + """ + array_ndim, array_type, array_shape, array_handle = \ + _artemis.f90wrap_species_type__array__atom(self._handle) + if array_handle in self._arrays: + atom = self._arrays[array_handle] + else: + atom = f90wrap.runtime.get_array(f90wrap.runtime.sizeof_fortran_t, + self._handle, + _artemis.f90wrap_species_type__array__atom) + self._arrays[array_handle] = atom + return atom + + @atom.setter + def atom(self, atom): + self.atom[...] = atom + + @property + def mass(self): + """ + The mass of the element. + """ + return _artemis.f90wrap_species_type__get__mass(self._handle) + + @mass.setter + def mass(self, mass): + _artemis.f90wrap_species_type__set__mass(self._handle, mass) + + @property + def charge(self): + """ + The charge of the element. + """ + return _artemis.f90wrap_species_type__get__charge(self._handle) + + @property + def radius(self): + """ + The radius of the element. + """ + return _artemis.f90wrap_species_type__get__radius(self._handle) + + @radius.setter + def radius(self, radius): + _artemis.f90wrap_species_type__set__radius(self._handle, radius) + + @charge.setter + def charge(self, charge): + _artemis.f90wrap_species_type__set__charge(self._handle, charge) + + @property + def name(self): + """ + The symbol of the element. + """ + return _artemis.f90wrap_species_type__get__name(self._handle) + + @name.setter + def name(self, name): + _artemis.f90wrap_species_type__set__name(self._handle, name) + + @property + def num(self): + """ + The number of atoms of this species/element. + """ + return _artemis.f90wrap_species_type__get__num(self._handle) + + @num.setter + def num(self, num): + _artemis.f90wrap_species_type__set__num(self._handle, num) + + def __str__(self): + ret = ['{\n'] + ret.append(' atom : ') + ret.append(repr(self.atom)) + ret.append(',\n mass : ') + ret.append(repr(self.mass)) + ret.append(',\n charge : ') + ret.append(repr(self.charge)) + ret.append(',\n name : ') + ret.append(repr(self.name)) + ret.append(',\n num : ') + ret.append(repr(self.num)) + ret.append('}') + return ''.join(ret) + + _dt_array_initialisers = [] + + + @f90wrap.runtime.register_class("artemis.basis") + class basis(f90wrap.runtime.FortranDerivedType): + def __init__(self, atoms=None, handle=None): + """ + Create a ``basis`` object. + + This object is used to store the atomic information of a crystal, + including lattice and basis information. + This is confusingly named as a crystal = lattice + basis. + + Returns: + basis (basis): + Object to be constructed + """ + f90wrap.runtime.FortranDerivedType.__init__(self) + result = _artemis.f90wrap_geom_rw__basis_type_initialise() + self._handle = result[0] if isinstance(result, tuple) else result + + if atoms is not None: + self.fromase(atoms) + + def __del__(self): + """ + Destructor for class basis + + + Defined at ../src/lib/mod_geom_rw.f90 lines \ + 34-42 + + Parameters + ---------- + this : basis + Object to be destructed + + + Automatically generated destructor for basis + """ + if self._alloc: + _artemis.f90wrap_geom_rw__basis_type_finalise(this=self._handle) + + def allocate_species(self, num_species=None, species_symbols=None, species_count=None, \ + positions=None): + """ + Allocate memory for the species list. + + Parameters: + num_species (int): + Number of species + species_symbols (list of str): + List of species symbols + species_count (list of int): + List of species counts + atoms (list of float): + List of atomic positions + """ + _artemis.f90wrap_geom_rw__allocate_species__binding__basis_type(this=self._handle, \ + num_species=num_species, species_symbols=species_symbols, species_count=species_count, \ + atoms=positions) + + def _init_array_spec(self): + """ + Initialise the species array. + """ + self.spec = f90wrap.runtime.FortranDerivedTypeArray(self, + _artemis.f90wrap_basis_type__array_getitem__spec, + _artemis.f90wrap_basis_type__array_setitem__spec, + _artemis.f90wrap_basis_type__array_len__spec, + """ + Element spec ftype=type(species_type) pytype=species_type + + + Defined at ../src/lib/mod_geom_rw.f90 line 35 + + """, Geom_Rw.species_type) + return self.spec + + def toase(self, calculator=None): + """ + Convert the basis object to an ASE Atoms object. + + Parameters: + calculator (ASE Calculator): + ASE calculator object to be assigned to the Atoms object. + """ + from ase import Atoms + + # Set the species list + positions = [] + species_string = "" + for i in range(self.nspec): + for j in range(self.spec[i].num): + species_string += str(self.spec[i].name.decode()).strip() + positions.append(self.spec[i].atom[j][:3]) + + # Set the atoms + if(self.lcart): + atoms = Atoms(species_string, positions=positions, cell=self.lat, pbc=self.pbc) + else: + atoms = Atoms(species_string, scaled_positions=positions, cell=self.lat, pbc=self.pbc) + + if calculator is not None: + atoms.calc = calculator + return atoms + + def fromase(self, atoms, verbose=False): + """ + Convert the ASE Atoms object to a basis object. + + Parameters: + atoms (ASE Atoms): + ASE Atoms object to be converted. + verbose (bool): + Boolean whether to print warnings. + """ + from ase.calculators.singlepoint import SinglePointCalculator + + # Get the species symbols + species_symbols = atoms.get_chemical_symbols() + species_symbols_unique = sorted(set(species_symbols)) + + # Set the number of species + self.nspec = len(species_symbols_unique) + + # Set the number of atoms + self.natom = len(atoms) + + # check if calculator is present + if atoms.calc is None: + if verbose: + print("WARNING: No calculator present, setting energy to 0.0") + atoms.calc = SinglePointCalculator(atoms, energy=0.0) + self.energy = atoms.get_potential_energy() + + # # Set the lattice vectors + self.lat = numpy.reshape(atoms.get_cell().flatten(), [3,3], order='A') + self.pbc = atoms.pbc + + # Set the system name + self.sysname = atoms.get_chemical_formula() + + # Set the species list + species_count = [] + atom_positions = [] + positions = atoms.get_scaled_positions() + for species in species_symbols_unique: + species_count.append(sum([1 for symbol in species_symbols if symbol == species])) + for j, symbol in enumerate(species_symbols): + if symbol == species: + atom_positions.append(positions[j]) + + # Allocate memory for the atom list + self.lcart = False + self.allocate_species(species_symbols=species_symbols_unique, species_count=species_count, positions=atom_positions) + + @property + def nspec(self): + """ + The number of species in the basis. + """ + return _artemis.f90wrap_basis_type__get__nspec(self._handle) + + @nspec.setter + def nspec(self, nspec): + _artemis.f90wrap_basis_type__set__nspec(self._handle, nspec) + + @property + def natom(self): + """ + The number of atoms in the basis. + """ + return _artemis.f90wrap_basis_type__get__natom(self._handle) + + @natom.setter + def natom(self, natom): + _artemis.f90wrap_basis_type__set__natom(self._handle, natom) + + @property + def energy(self): + """ + The energy associated with the basis (or crystal). + """ + return _artemis.f90wrap_basis_type__get__energy(self._handle) + + @energy.setter + def energy(self, energy): + _artemis.f90wrap_basis_type__set__energy(self._handle, energy) + + @property + def lat(self): + """ + The lattice vectors of the basis. + """ + array_ndim, array_type, array_shape, array_handle = \ + _artemis.f90wrap_basis_type__array__lat(self._handle) + if array_handle in self._arrays: + lat = self._arrays[array_handle] + else: + lat = f90wrap.runtime.get_array(f90wrap.runtime.sizeof_fortran_t, + self._handle, + _artemis.f90wrap_basis_type__array__lat) + self._arrays[array_handle] = lat + return lat + + @lat.setter + def lat(self, lat): + self.lat[...] = lat + + @property + def lcart(self): + """ + Boolean whether the atomic positions are in cartesian coordinates. + """ + return _artemis.f90wrap_basis_type__get__lcart(self._handle) + + @lcart.setter + def lcart(self, lcart): + _artemis.f90wrap_basis_type__set__lcart(self._handle, lcart) + + @property + def pbc(self): + """ + Boolean array indicating the periodic boundary conditions. + """ + array_ndim, array_type, array_shape, array_handle = \ + _artemis.f90wrap_basis_type__array__pbc(self._handle) + if array_handle in self._arrays: + pbc = self._arrays[array_handle] + else: + pbc = f90wrap.runtime.get_array(f90wrap.runtime.sizeof_fortran_t, + self._handle, + _artemis.f90wrap_basis_type__array__pbc) + self._arrays[array_handle] = pbc + return pbc + + @pbc.setter + def pbc(self, pbc): + self.pbc[...] = pbc + + @property + def sysname(self): + """ + The name of the system. + """ + return _artemis.f90wrap_basis_type__get__sysname(self._handle) + + @sysname.setter + def sysname(self, sysname): + _artemis.f90wrap_basis_type__set__sysname(self._handle, sysname) + + def __str__(self): + ret = ['{\n'] + ret.append(' nspec : ') + ret.append(repr(self.nspec)) + ret.append(',\n natom : ') + ret.append(repr(self.natom)) + ret.append(',\n energy : ') + ret.append(repr(self.energy)) + ret.append(',\n lat : ') + ret.append(repr(self.lat)) + ret.append(',\n lcart : ') + ret.append(repr(self.lcart)) + ret.append(',\n pbc : ') + ret.append(repr(self.pbc)) + ret.append(',\n sysname : ') + ret.append(repr(self.sysname)) + ret.append('}') + return ''.join(ret) + + _dt_array_initialisers = [_init_array_spec] + + + + @f90wrap.runtime.register_class("artemis.basis_array") + class basis_array(f90wrap.runtime.FortranDerivedType): + def __init__(self, atoms=None, handle=None): + """ + Create a ``basis_array`` object. + + + Returns: + basis_array (basis_array): + Object to be constructed + """ + + f90wrap.runtime.FortranDerivedType.__init__(self) + result = _artemis.f90wrap_geom_rw__basis_type_xnum_array_initialise() + self._handle = result[0] if isinstance(result, tuple) else result + + + # check if atoms is an ASE Atoms object or a list of ASE Atoms objects + if atoms: + from ase import Atoms + if isinstance(atoms, Atoms): + self.allocate(1) + self.items[0].fromase(atoms) + elif isinstance(atoms, list): + self.allocate(len(atoms)) + for i, atom in enumerate(atoms): + self.items[i].fromase(atom) + + def __del__(self): + """ + Destructor for class basis_array + + + Defined at ../src/lib/mod_generator.f90 lines \ + 19-21 + + Parameters + ---------- + this : basis_array + Object to be destructed + + + Automatically generated destructor for basis_array + """ + if self._alloc: + _artemis.f90wrap_geom_rw__basis_type_xnum_array_finalise(this=self._handle) + + def _init_array_items(self): + """ + Initialise the items array. + """ + self.items = f90wrap.runtime.FortranDerivedTypeArray(self, + _artemis.f90wrap_basis_type_xnum_array__array_getitem__items, + _artemis.f90wrap_basis_type_xnum_array__array_setitem__items, + _artemis.f90wrap_basis_type_xnum_array__array_len__items, + """ + Element items ftype=type(basis_type) pytype=basis + + + Defined at line 0 + + """, Geom_Rw.basis) + return self.items + + def toase(self, calculator=None): + """ + Convert the basis_array object to a list of ASE Atoms objects. + """ + + # Set the species list + atoms = [] + for i in range(len(self.items)): + atoms.append(self.items[i].toase(calculator=calculator)) + return atoms + + def allocate(self, size): + """ + Allocate the items array with the given size. + + Parameters: + size (int): + Size of the items array + """ + _artemis.f90wrap_basis_type_xnum_array__array_alloc__items(self._handle, num=size) + + def deallocate(self): + """ + Deallocate the items array + """ + _artemis.f90wrap_basis_type_xnum_array__array_dealloc__items(self._handle) + + _dt_array_initialisers = [_init_array_items] + + _dt_array_initialisers = [] + + +geom_rw = Geom_Rw() + + + + +class Misc_Types(f90wrap.runtime.FortranModule): + """ + Module artemis__misc_types + + + Defined at \ + ../fortran/lib/mod_misc_types.f90 \ + lines 1-261 + + """ + @f90wrap.runtime.register_class("artemis.struc_data_type") + class struc_data_type(f90wrap.runtime.FortranDerivedType): + """ + Type(name=struc_data_type) + + + Defined at \ + ../fortran/lib/mod_misc_types.f90 \ + lines 24-42 + + """ + def __init__(self, handle=None): + """ + self = Struc_Data_Type() + + + Defined at \ + ../fortran/lib/mod_misc_types.f90 \ + lines 24-42 + + + Returns + ------- + this : Struc_Data_Type + Object to be constructed + + + Automatically generated constructor for struc_data_type + """ + f90wrap.runtime.FortranDerivedType.__init__(self) + result = _artemis.f90wrap_misc_types__struc_data_type_initialise() + self._handle = result[0] if isinstance(result, tuple) else result + + def __del__(self): + """ + Destructor for class Struc_Data_Type + + + Defined at \ + ../fortran/lib/mod_misc_types.f90 \ + lines 24-42 + + Parameters + ---------- + this : Struc_Data_Type + Object to be destructed + + + Automatically generated destructor for struc_data_type + """ + if self._alloc: + _artemis.f90wrap_misc_types__struc_data_type_finalise(this=self._handle) + + @property + def match_idx(self): + """ + Element match_idx ftype=integer pytype=int + + + Defined at \ + ../fortran/lib/mod_misc_types.f90 \ + line 25 + + """ + return _artemis.f90wrap_struc_data_type__get__match_idx(self._handle) + + @match_idx.setter + def match_idx(self, match_idx): + _artemis.f90wrap_struc_data_type__set__match_idx(self._handle, match_idx) + + @property + def shift_idx(self): + """ + Element shift_idx ftype=integer pytype=int + + + Defined at \ + ../fortran/lib/mod_misc_types.f90 \ + line 26 + + """ + return _artemis.f90wrap_struc_data_type__get__shift_idx(self._handle) + + @shift_idx.setter + def shift_idx(self, shift_idx): + _artemis.f90wrap_struc_data_type__set__shift_idx(self._handle, shift_idx) + + @property + def swap_idx(self): + """ + Element swap_idx ftype=integer pytype=int + + + Defined at \ + ../fortran/lib/mod_misc_types.f90 \ + line 27 + + """ + return _artemis.f90wrap_struc_data_type__get__swap_idx(self._handle) + + @swap_idx.setter + def swap_idx(self, swap_idx): + _artemis.f90wrap_struc_data_type__set__swap_idx(self._handle, swap_idx) + + @property + def from_pricel_lw(self): + """ + Element from_pricel_lw ftype=logical pytype=bool + + + Defined at \ + ../fortran/lib/mod_misc_types.f90 \ + line 28 + + """ + return _artemis.f90wrap_struc_data_type__get__from_pricel_lw(self._handle) + + @from_pricel_lw.setter + def from_pricel_lw(self, from_pricel_lw): + _artemis.f90wrap_struc_data_type__set__from_pricel_lw(self._handle, \ + from_pricel_lw) + + @property + def from_pricel_up(self): + """ + Element from_pricel_up ftype=logical pytype=bool + + + Defined at \ + ../fortran/lib/mod_misc_types.f90 \ + line 29 + + """ + return _artemis.f90wrap_struc_data_type__get__from_pricel_up(self._handle) + + @from_pricel_up.setter + def from_pricel_up(self, from_pricel_up): + _artemis.f90wrap_struc_data_type__set__from_pricel_up(self._handle, \ + from_pricel_up) + + @property + def term_lw_idx(self): + """ + Element term_lw_idx ftype=integer pytype=int + + + Defined at \ + ../fortran/lib/mod_misc_types.f90 \ + line 30 + + """ + array_ndim, array_type, array_shape, array_handle = \ + _artemis.f90wrap_struc_data_type__array__term_lw_idx(self._handle) + if array_handle in self._arrays: + term_lw_idx = self._arrays[array_handle] + else: + term_lw_idx = f90wrap.runtime.get_array(f90wrap.runtime.sizeof_fortran_t, + self._handle, + _artemis.f90wrap_struc_data_type__array__term_lw_idx) + self._arrays[array_handle] = term_lw_idx + return term_lw_idx + + @term_lw_idx.setter + def term_lw_idx(self, term_lw_idx): + self.term_lw_idx[...] = term_lw_idx + + @property + def term_up_idx(self): + """ + Element term_up_idx ftype=integer pytype=int + + + Defined at \ + ../fortran/lib/mod_misc_types.f90 \ + line 31 + + """ + array_ndim, array_type, array_shape, array_handle = \ + _artemis.f90wrap_struc_data_type__array__term_up_idx(self._handle) + if array_handle in self._arrays: + term_up_idx = self._arrays[array_handle] + else: + term_up_idx = f90wrap.runtime.get_array(f90wrap.runtime.sizeof_fortran_t, + self._handle, + _artemis.f90wrap_struc_data_type__array__term_up_idx) + self._arrays[array_handle] = term_up_idx + return term_up_idx + + @term_up_idx.setter + def term_up_idx(self, term_up_idx): + self.term_up_idx[...] = term_up_idx + + @property + def transform_lw(self): + """ + Element transform_lw ftype=integer pytype=int + + + Defined at \ + ../fortran/lib/mod_misc_types.f90 \ + line 32 + + """ + array_ndim, array_type, array_shape, array_handle = \ + _artemis.f90wrap_struc_data_type__array__transform_lw(self._handle) + if array_handle in self._arrays: + transform_lw = self._arrays[array_handle] + else: + transform_lw = f90wrap.runtime.get_array(f90wrap.runtime.sizeof_fortran_t, + self._handle, + _artemis.f90wrap_struc_data_type__array__transform_lw) + self._arrays[array_handle] = transform_lw + return transform_lw + + @transform_lw.setter + def transform_lw(self, transform_lw): + self.transform_lw[...] = transform_lw + + @property + def transform_up(self): + """ + Element transform_up ftype=integer pytype=int + + + Defined at \ + ../fortran/lib/mod_misc_types.f90 \ + line 33 + + """ + array_ndim, array_type, array_shape, array_handle = \ + _artemis.f90wrap_struc_data_type__array__transform_up(self._handle) + if array_handle in self._arrays: + transform_up = self._arrays[array_handle] + else: + transform_up = f90wrap.runtime.get_array(f90wrap.runtime.sizeof_fortran_t, + self._handle, + _artemis.f90wrap_struc_data_type__array__transform_up) + self._arrays[array_handle] = transform_up + return transform_up + + @transform_up.setter + def transform_up(self, transform_up): + self.transform_up[...] = transform_up + + @property + def approx_thickness_lw(self): + """ + Element approx_thickness_lw ftype=real(real32) pytype=float + + + Defined at \ + ../fortran/lib/mod_misc_types.f90 \ + line 34 + + """ + return _artemis.f90wrap_struc_data_type__get__approx_thickness_lw(self._handle) + + @approx_thickness_lw.setter + def approx_thickness_lw(self, approx_thickness_lw): + _artemis.f90wrap_struc_data_type__set__approx_thickness_lw(self._handle, \ + approx_thickness_lw) + + @property + def approx_thickness_up(self): + """ + Element approx_thickness_up ftype=real(real32) pytype=float + + + Defined at \ + ../fortran/lib/mod_misc_types.f90 \ + line 35 + + """ + return _artemis.f90wrap_struc_data_type__get__approx_thickness_up(self._handle) + + @approx_thickness_up.setter + def approx_thickness_up(self, approx_thickness_up): + _artemis.f90wrap_struc_data_type__set__approx_thickness_up(self._handle, \ + approx_thickness_up) + + @property + def mismatch(self): + """ + Element mismatch ftype=real(real32) pytype=float + + + Defined at \ + ../fortran/lib/mod_misc_types.f90 \ + line 36 + + """ + array_ndim, array_type, array_shape, array_handle = \ + _artemis.f90wrap_struc_data_type__array__mismatch(self._handle) + if array_handle in self._arrays: + mismatch = self._arrays[array_handle] + else: + mismatch = f90wrap.runtime.get_array(f90wrap.runtime.sizeof_fortran_t, + self._handle, + _artemis.f90wrap_struc_data_type__array__mismatch) + self._arrays[array_handle] = mismatch + return mismatch + + @mismatch.setter + def mismatch(self, mismatch): + self.mismatch[...] = mismatch + + @property + def shift(self): + """ + Element shift ftype=real(real32) pytype=float + + + Defined at \ + ../fortran/lib/mod_misc_types.f90 \ + line 37 + + """ + array_ndim, array_type, array_shape, array_handle = \ + _artemis.f90wrap_struc_data_type__array__shift(self._handle) + if array_handle in self._arrays: + shift = self._arrays[array_handle] + else: + shift = f90wrap.runtime.get_array(f90wrap.runtime.sizeof_fortran_t, + self._handle, + _artemis.f90wrap_struc_data_type__array__shift) + self._arrays[array_handle] = shift + return shift + + @shift.setter + def shift(self, shift): + self.shift[...] = shift + + @property + def swap_density(self): + """ + Element swap_density ftype=real(real32) pytype=float + + + Defined at \ + ../fortran/lib/mod_misc_types.f90 \ + line 39 + + """ + return _artemis.f90wrap_struc_data_type__get__swap_density(self._handle) + + @swap_density.setter + def swap_density(self, swap_density): + _artemis.f90wrap_struc_data_type__set__swap_density(self._handle, swap_density) + + @property + def approx_eff_swap_conc(self): + """ + Element approx_eff_swap_conc ftype=real(real32) pytype=float + + + Defined at \ + ../fortran/lib/mod_misc_types.f90 \ + line 40 + + """ + array_ndim, array_type, array_shape, array_handle = \ + _artemis.f90wrap_struc_data_type__array__approx_eff_swap_conc(self._handle) + if array_handle in self._arrays: + approx_eff_swap_conc = self._arrays[array_handle] + else: + approx_eff_swap_conc = \ + f90wrap.runtime.get_array(f90wrap.runtime.sizeof_fortran_t, + self._handle, + _artemis.f90wrap_struc_data_type__array__approx_eff_swap_conc) + self._arrays[array_handle] = approx_eff_swap_conc + return approx_eff_swap_conc + + @approx_eff_swap_conc.setter + def approx_eff_swap_conc(self, approx_eff_swap_conc): + self.approx_eff_swap_conc[...] = approx_eff_swap_conc + + def __str__(self): + ret = ['{\n'] + ret.append(' match_idx : ') + ret.append(repr(self.match_idx)) + ret.append(',\n shift_idx : ') + ret.append(repr(self.shift_idx)) + ret.append(',\n swap_idx : ') + ret.append(repr(self.swap_idx)) + ret.append(',\n from_pricel_lw : ') + ret.append(repr(self.from_pricel_lw)) + ret.append(',\n from_pricel_up : ') + ret.append(repr(self.from_pricel_up)) + ret.append(',\n term_lw_idx : ') + ret.append(repr(self.term_lw_idx)) + ret.append(',\n term_up_idx : ') + ret.append(repr(self.term_up_idx)) + ret.append(',\n transform_lw : ') + ret.append(repr(self.transform_lw)) + ret.append(',\n transform_up : ') + ret.append(repr(self.transform_up)) + ret.append(',\n approx_thickness_lw : ') + ret.append(repr(self.approx_thickness_lw)) + ret.append(',\n approx_thickness_up : ') + ret.append(repr(self.approx_thickness_up)) + ret.append(',\n mismatch : ') + ret.append(repr(self.mismatch)) + ret.append(',\n shift : ') + ret.append(repr(self.shift)) + ret.append(',\n swap_density : ') + ret.append(repr(self.swap_density)) + ret.append(',\n approx_eff_swap_conc : ') + ret.append(repr(self.approx_eff_swap_conc)) + ret.append('}') + return ''.join(ret) + + _dt_array_initialisers = [] + + +misc_types = Misc_Types() + + + + +class Generator(f90wrap.runtime.FortranModule): + """ + Module artemis__generator + + + Defined at \ + ../src/fortran/lib/mod_intf_generator.f90 \ + lines 7-1373 + + """ + @f90wrap.runtime.register_class("artemis.artemis_generator") + class artemis_generator(f90wrap.runtime.FortranDerivedType): + """ + Type(name=artemis_generator_type) + + + Defined at \ + ../src/fortran/lib/mod_intf_generator.f90 \ + lines 30-75 + + """ + def __init__(self, handle=None): + """ + self = Artemis_generator_Type() + + + Defined at \ + ../src/fortran/lib/mod_intf_generator.f90 \ + lines 30-75 + + + Returns + ------- + this : Artemis_generator_Type + Object to be constructed + + + Automatically generated constructor for artemis_generator_type + """ + f90wrap.runtime.FortranDerivedType.__init__(self) + result = \ + _artemis.f90wrap_intf_gen__artemis_gen_type_initialise() + self._handle = result[0] if isinstance(result, tuple) else result + + def __del__(self): + """ + Destructor for class Artemis_generator_Type + + + Defined at \ + ../src/fortran/lib/mod_intf_generator.f90 \ + lines 30-75 + + Parameters + ---------- + this : Artemis_generator_Type + Object to be destructed + + + Automatically generated destructor for artemis_generator_type + """ + if self._alloc: + _artemis.f90wrap_intf_gen__artemis_gen_type_finalise(this=self._handle) + + def get_all_structures_data(self): + """ + output = get_all_structure_data__binding__artemis_generator_type(self) + + + Defined at \ + ../fortran/lib/mod_generator.f90 \ + lines 134-146 + + Parameters + ---------- + this : Artemis_Generator_Type + + Returns + ------- + output : Struc_Data_Type array + + """ + output = [] + for i in range(self.num_structures): + output.append(self.get_structure_data(i)) + + # output = \ + # _artemis.f90wrap_intf_gen__get_all_structures_data__binding_agt(this=self._handle) + # output = \ + # f90wrap.runtime.lookup_class("artemis.struc_data_type").from_handle(output, \ + # alloc=True) + return output + + def get_structure_data(self, idx: int): + """ + output = get_structure_data__binding__artemis_generator_type(self, idx) + + + Defined at \ + ../fortran/lib/mod_generator.f90 \ + lines 150-160 + + Parameters + ---------- + this : Artemis_Generator_Type + idx : int + + Returns + ------- + output : Struc_Data_Type + + """ + output = \ + _artemis.f90wrap_intf_gen__get_structure_data__binding_agt(this=self._handle, \ + idx=idx) + output = \ + f90wrap.runtime.lookup_class("artemis.struc_data_type").from_handle(output, \ + alloc=True) + + output_dict = { + 'match_idx': output.match_idx, + 'shift_idx': output.shift_idx, + 'swap_idx': output.swap_idx, + 'from_pricel_lw': output.from_pricel_lw, + 'from_pricel_up': output.from_pricel_up, + 'term_lw_idx': output.term_lw_idx, + 'term_up_idx': output.term_up_idx, + 'transform_lw': output.transform_lw, + 'transform_up': output.transform_up, + 'approx_thickness_lw': output.approx_thickness_lw, + 'approx_thickness_up': output.approx_thickness_up, + 'mismatch': output.mismatch, + 'shift': output.shift, + 'swap_density': output.swap_density, + 'approx_eff_swap_conc': output.approx_eff_swap_conc + } + + return output_dict + + def get_all_structures_mismatch(self): + """ + output = get_all_structures_mismatch__binding__artemis_generator_type(self) + + + Defined at \ + ../fortran/lib/mod_generator.f90 \ + lines 130-142 + + Parameters + ---------- + this : Artemis_Generator_Type + + Returns + ------- + output : float array + + """ + output = \ + _artemis.f90wrap_intf_gen__get_all_structures_mismatch__binding_agt(this=self._handle) + return output + + def get_structure_mismatch(self, idx: int): + """ + output = get_structure_mismatch__binding__artemis_generator_type(self, idx) + + + Defined at \ + ../fortran/lib/mod_generator.f90 \ + lines 146-156 + + Parameters + ---------- + this : Artemis_Generator_Type + idx : int + + Returns + ------- + output : float array + + """ + output = \ + _artemis.f90wrap_intf_gen__get_structure_mismatch__binding_agt(this=self._handle, \ + idx=idx) + return output + + def get_all_structures_transform(self): + """ + output = get_all_structures_transform__binding__artemis_generator_type(self) + + + Defined at \ + ../fortran/lib/mod_generator.f90 \ + lines 160-174 + + Parameters + ---------- + this : Artemis_Generator_Type + + Returns + ------- + output : int array + + """ + output = \ + _artemis.f90wrap_intf_gen__get_all_structures_transform__binding_agt(this=self._handle) + return output + + def get_structure_transform(self, idx: int): + """ + output = get_structure_transform__binding__artemis_generator_type(self, idx) + + + Defined at \ + ../fortran/lib/mod_generator.f90 \ + lines 178-189 + + Parameters + ---------- + this : Artemis_Generator_Type + idx : int + + Returns + ------- + output : int array + + """ + output = \ + _artemis.f90wrap_intf_gen__get_structure_transform__binding_agt(this=self._handle, \ + idx=idx) + return output + + def get_all_structures_shift(self): + """ + output = get_all_structures_shifts__binding__artemis_generator_type(self) + + + Defined at \ + ../fortran/lib/mod_generator.f90 \ + lines 193-205 + + Parameters + ---------- + this : Artemis_Generator_Type + + Returns + ------- + output : float array + + """ + # get number of structures + num_structures = self.num_structures + output = \ + _artemis.f90wrap_intf_gen__get_all_structures_shift__binding_agt(this=self._handle, n0=num_structures) + return output + + def get_structure_shift(self, idx: int): + """ + output = get_structure_shifts__binding__artemis_generator_type(self, idx) + + + Defined at \ + ../fortran/lib/mod_generator.f90 \ + lines 209-219 + + Parameters + ---------- + this : Artemis_Generator_Type + idx : int + + Returns + ------- + output : float array + + """ + output = \ + _artemis.f90wrap_intf_gen__get_structure_shift__binding_agt(this=self._handle, \ + idx=idx) + return output + + def set_tolerance( + self, + vector_mismatch: float = None, + angle_mismatch: float = None, + area_mismatch: float = None, + max_length: float = None, + max_area: float = None, + max_fit: int = None, + max_extension: int = None, + angle_weight: float = None, + area_weight: float = None + ): + """ + set_tolerance__binding__artemis_gen_type(self[, vector_mismatch, \ + angle_mismatch, area_mismatch, max_length, max_area, max_fit, max_extension, \ + angle_weight, area_weight]) + + + Defined at \ + ../src/fortran/lib/mod_intf_generator.f90 \ + lines 85-125 + + Parameters + ---------- + this : Artemis_generator_Type + vector_mismatch : float + angle_mismatch : float + area_mismatch : float + max_length : float + max_area : float + max_fit : int + max_extension : int + angle_weight : float + area_weight : float + + """ + if max_extension is not None and not isinstance(max_extension, int): + raise TypeError("max_extension must be an int") + if max_fit is not None and not isinstance(max_fit, int): + raise TypeError("max_fit must be an int") + + _artemis.f90wrap_intf_gen__set_tolerance__binding_agt(this=self._handle, \ + vector_mismatch=vector_mismatch, angle_mismatch=angle_mismatch, \ + area_mismatch=area_mismatch, max_length=max_length, max_area=max_area, \ + max_fit=max_fit, max_extension=max_extension, angle_weight=angle_weight, \ + area_weight=area_weight) + + def set_shift_method( + self, + method: int = None, + num_shifts: int = None, + shifts: list[float] | numpy.ndarray = None, + interface_depth: float = None, + separation_scale: float = None, + depth_method: int = None, + bondlength_cutoff: float = None + ): + """ + set_shift_method__binding__artemis_generator_type(self[, method, num_shifts, \ + shifts, interface_depth, separation_scale, depth_method, bondlength_cutoff]) + + + Defined at \ + ../fortran/lib/mod_generator.f90 \ + lines 180-252 + + Parameters + ---------- + this : Artemis_Generator_Type + method : int + num_shifts : int + shifts : float array + interface_depth : float + separation_scale : float + depth_method : int + bondlength_cutoff : float + + """ + + if shifts is not None: + # if shifts is a scalar, convert it to a 2D array, fortran order + if isinstance(shifts, float) or isinstance(shifts, int): + shifts = numpy.array([[shifts]], order='F') + # if shifts is a 1D array, convert it to a 2D array, fortran order + elif isinstance(shifts, list): + shifts = numpy.array([shifts], order='F') + elif len(shifts.shape) == 1: + shifts = numpy.array([shifts], order='F') + # if shifts is a 2D array, convert it to a 2D array, fortran order + elif len(shifts.shape) == 2: + shifts = numpy.array(shifts, order='F') + + _artemis.f90wrap_intf_gen__set_shift_method__binding__agt(this=self._handle, \ + method=method, num_shifts=num_shifts, shifts=shifts, \ + interface_depth=interface_depth, separation_scale=separation_scale, \ + depth_method=depth_method, bondlength_cutoff=bondlength_cutoff) + + def set_swap_method( + self, + method: int = None, + num_swaps: int = None, + swap_density: float = None, + swap_depth: float = None, + swap_sigma: float = None, + require_mirror_swaps: bool = None + ): + """ + set_swap_method__binding__artemis_generator_type(self[, method, num_swaps, \ + swap_density, swap_depth, swap_sigma, require_mirror_swaps]) + + + Defined at \ + ../fortran/lib/mod_generator.f90 \ + lines 259-283 + + Parameters + ---------- + this : Artemis_Generator_Type + method : int + num_swaps : int + swap_density : float + swap_depth : float + swap_sigma : float + require_mirror_swaps : bool + + """ + _artemis.f90wrap_intf_gen__set_swap_method__binding__agt(this=self._handle, \ + method=method, num_swaps=num_swaps, swap_density=swap_density, \ + swap_depth=swap_depth, swap_sigma=swap_sigma, \ + require_mirror_swaps=require_mirror_swaps) + + def set_match_method( + self, + method: int = None, + max_num_matches: int = None, + max_num_terms: int = None, + max_num_planes: int = None, + compensate_normal: bool = None + ): + """ + set_match_method__binding__artemis_generator_type(self[, method, \ + max_num_matches, max_num_terms, max_num_planes, compensate_normal]) + + + Defined at \ + ../fortran/lib/mod_generator.f90 \ + lines 290-310 + + Parameters + ---------- + this : Artemis_Generator_Type + method : int + max_num_matches : int + max_num_terms : int + max_num_planes : int + compensate_normal : bool + + """ + _artemis.f90wrap_intf_gen__set_match_method__binding__agt(this=self._handle, \ + method=method, max_num_matches=max_num_matches, max_num_terms=max_num_terms, \ + max_num_planes=max_num_planes, compensate_normal=compensate_normal) + + def set_materials( + self, + structure_lw: Atoms | Geom_Rw.basis = None, + structure_up: Atoms | Geom_Rw.basis = None, + elastic_lw: float | list[float] | numpy.ndarray = None, + elastic_up: float | list[float] | numpy.ndarray = None, + use_pricel_lw: bool = None, + use_pricel_up: bool = None + ): + """ + set_materials__binding__artemis_gen_type(self, structure_lw, \ + structure_up[, elastic_tensor_lw, elastic_tensor_up, use_pricel_lw, \ + use_pricel_up]) + + + Defined at \ + ../fortran/lib/mod_intf_generator.f90 \ + lines 252-287 + + Parameters + ---------- + this : Artemis_generator_Type + structure_lw : Basis_Type + structure_up : Basis_Type + elastic_lw : float array + elastic_up : float array + use_pricel_lw : bool + use_pricel_up : bool + + --------------------------------------------------------------------------- + Handle the elastic constants + --------------------------------------------------------------------------- + """ + + # check if host is ase.Atoms object or a Fortran derived type basis_type + if structure_lw is None: + structure_lw_handle = None + else: + if isinstance(structure_lw, Atoms): + structure_lw = geom_rw.basis(atoms=structure_lw) + structure_lw_handle = structure_lw._handle + + if structure_up is None: + structure_up_handle = None + else: + if isinstance(structure_up, Atoms): + structure_up = geom_rw.basis(atoms=structure_up) + structure_up_handle = structure_up._handle + + # check if length of elastic is either 1 or 36 or None, else break + if elastic_lw is not None: + if isinstance(elastic_lw, float) or isinstance(elastic_lw, int): + elastic_lw = numpy.array([elastic_lw]) + elif isinstance(elastic_lw, list) or isinstance(elastic_lw, tuple): + elastic_lw = numpy.array(elastic_lw) + if elastic_lw.size != 1 and elastic_lw.size != 36: + raise ValueError("elastic_lw must be either 1 or 36 elements long") + # convert to a 2D array of shape (1,1) or (6,6) + if elastic_lw.size == 1: + elastic_lw = numpy.array([[elastic_lw[0]]], order='F') + else: + elastic_lw = numpy.array(elastic_lw, order='F') + elastic_lw = numpy.reshape(elastic_lw, (6, 6), order='F') + if elastic_up is not None: + if isinstance(elastic_up, float) or isinstance(elastic_up, int): + elastic_up = numpy.array([elastic_up]) + elif isinstance(elastic_up, list) or isinstance(elastic_up, tuple): + elastic_up = numpy.array(elastic_up) + if elastic_up.size != 1 and elastic_up.size != 36: + raise ValueError("elastic_up must be either 1 or 36 elements long") + # convert to a 2D array of shape (1,1) or (6,6) + if elastic_up.size == 1: + elastic_up = numpy.array([[elastic_up[0]]], order='F') + else: + elastic_up = numpy.array(elastic_up, order='F') + elastic_up = numpy.reshape(elastic_up, (6, 6), order='F') + + _artemis.f90wrap_intf_gen__set_materials__binding__agt(this=self._handle, \ + structure_lw=structure_lw_handle, structure_up=structure_up_handle, \ + elastic_lw=elastic_lw, \ + elastic_up=elastic_up, use_pricel_lw=use_pricel_lw, \ + use_pricel_up=use_pricel_up) + + def set_surface_properties( + self, + miller_lw: list[int] | Tuple[float, float, float] = None, + miller_up: list[int] | Tuple[float, float, float] = None, + is_layered_lw: bool = None, + is_layered_up: bool = None, + require_stoichiometry_lw: bool = None, + require_stoichiometry_up: bool = None, + layer_separation_cutoff_lw: float = None, + layer_separation_cutoff_up: float = None, + layer_separation_cutoff: float = None, + vacuum_gap: float = None + ): + """ + set_surface_properties__binding__artemis_generator_type(self[, miller_lw, \ + miller_up, is_layered_lw, is_layered_up, layer_separation_cutoff_lw, \ + layer_separation_cutoff_up, layer_separation_cutoff, vacuum_gap]) + + + Defined at \ + ../fortran/lib/mod_generator.f90 \ + lines 364-435 + + Parameters + ---------- + this : Artemis_Generator_Type + miller_lw : int array + miller_up : int array + is_layered_lw : bool + is_layered_up : bool + require_stoichiometry_lw : bool + require_stoichiometry_up : bool + layer_separation_cutoff_lw : float + layer_separation_cutoff_up : float + layer_separation_cutoff : float array + vacuum_gap : float + + """ + + if miller_lw is not None and len(miller_lw) != 3: + raise ValueError("miller_lw must have exactly three elements") + + if miller_up is not None and len(miller_up) != 3: + raise ValueError("miller_up must have exactly three elements") + + _artemis.f90wrap_intf_gen__set_surface_properties__binding__agt(this=self._handle, \ + miller_lw=miller_lw, miller_up=miller_up, is_layered_lw=is_layered_lw, \ + is_layered_up=is_layered_up, \ + require_stoichiometry_lw=require_stoichiometry_lw, \ + require_stoichiometry_up=require_stoichiometry_up, \ + layer_separation_cutoff_lw=layer_separation_cutoff_lw, \ + layer_separation_cutoff_up=layer_separation_cutoff_up, \ + layer_separation_cutoff=layer_separation_cutoff, vacuum_gap=vacuum_gap) + + def reset_is_layered_lw(self): + """ + reset_is_layered_lw__binding__artemis_gen_type(self) + + + Defined at \ + ../fortran/lib/mod_intf_generator.f90 \ + lines 322-329 + + Parameters + ---------- + this : Artemis_generator_Type + + """ + _artemis.f90wrap_intf_gen__reset_is_layered_lw__binding__agt(this=self._handle) + + def reset_is_layered_up(self): + """ + reset_is_layered_up__binding__artemis_gen_type(self) + + + Defined at \ + ../fortran/lib/mod_intf_generator.f90 \ + lines 333-340 + + Parameters + ---------- + this : Artemis_generator_Type + + """ + _artemis.f90wrap_intf_gen__reset_is_layered_up__binding__agt(this=self._handle) + + def get_terminations_lw( + self, + miller: list[int] | Tuple[float, float, float] = None, + surface: int = None, + num_layers: int = None, + thickness: float = None, + orthogonalise: bool = None, + normalise: bool = None, + break_on_fail: bool = None, + verbose: int = None, + return_exit_code: bool = False, + calc = None + ): + """ + + Defined at \ + ../src/fortran/lib/mod_intf_generator.f90 \ + + Parameters + ---------- + """ + exit_code = 0 + structures = None + + if len(miller) != 3: + raise ValueError("miller must have exactly three elements") + + exit_code, n_structs = _artemis.f90wrap_intf_gen__get_terminations__binding__agt(this=self._handle, + identifier=1, + miller=miller, surface=surface, + num_layers=num_layers, thickness=thickness, + orthogonalise=orthogonalise, normalise=normalise, + break_on_fail=break_on_fail, + verbose=verbose) + if ( exit_code != 0 and exit_code != None ) and not return_exit_code: + raise RuntimeError(f"Termination generation failed (exit code {exit_code})") + + # allocate the structures + structures = geom_rw.basis_array() #.allocate(n_structs) + structures.allocate(n_structs) + _artemis.f90wrap_retrieve_last_generated_structures(structures._handle) + structures = structures.toase(calculator=calc) + + if return_exit_code: + return structures, exit_code + return structures + + def get_terminations_up( + self, + miller: list[int] | Tuple[float, float, float] = None, + surface: int = None, + num_layers: int = None, + thickness: float = None, + orthogonalise: bool = None, + normalise: bool = None, + break_on_fail: bool = None, + verbose: int = None, + return_exit_code: bool = False, + calc = None + ): + """ + + Defined at \ + ../src/fortran/lib/mod_intf_generator.f90 \ + + Parameters + ---------- + """ + exit_code = 0 + structures = None + + if len(miller) != 3: + raise ValueError("miller must have exactly three elements") + + exit_code, n_structs = _artemis.f90wrap_intf_gen__get_terminations__binding__agt(this=self._handle, + identifier=2, + miller=miller, surface=surface, + num_layers=num_layers, thickness=thickness, + orthogonalise=orthogonalise, normalise=normalise, + break_on_fail=break_on_fail, + verbose=verbose) + if ( exit_code != 0 and exit_code != None ) and not return_exit_code: + raise RuntimeError(f"Termination generation failed (exit code {exit_code})") + + # allocate the structures + structures = geom_rw.basis_array() #.allocate(n_structs) + structures.allocate(n_structs) + _artemis.f90wrap_retrieve_last_generated_structures(structures._handle) + structures = structures.toase(calculator=calc) + + if return_exit_code: + return structures, exit_code + return structures + + def get_interface_location( + self, + structure: Atoms | Geom_Rw.basis, + axis: int = None, + return_fractional: bool = False + ): + + """ + get_interface_location__binding__artemis_gen_type(self, structure, axis) + + + Defined at \ + ../src/fortran/lib/mod_intf_generator.f90 \ + lines 1112-1124 + + Parameters: + this : Artemis_generator_Type + structure : Basis_Type + axis : int + return_fractional : bool + If True, return the location in fractional coordinates. + If False, return the location in angstroms. + + Returns: + location : list of floats + The location of the interface in the structure (in Å). + axis : int + The axis of the interface. + """ + if isinstance(structure, Atoms): + structure = geom_rw.basis(atoms=structure) + + ret_location, ret_axis = _artemis.f90wrap_intf_gen__get_interface_location__binding__agt(this=self._handle, \ + structure=structure._handle, axis=axis, return_fractional=return_fractional) + + if ret_axis != axis and axis is not None: + raise RuntimeError(f"Interface location generation failed (axis {ret_axis} != {axis})") + + # convert the location from numpy array to list + if isinstance(ret_location, numpy.ndarray): + ret_location = ret_location.tolist() + + return ret_location, ret_axis + + + def generate( + self, + surface_lw: int = None, + surface_up: int = None, + thickness_lw: float = None, + thickness_up: float = None, + num_layers_lw: int = None, + num_layers_up: int = None, + reduce_matches: bool = None, + print_lattice_match_info: bool = None, + print_termination_info: bool = None, + print_shift_info: bool = None, + break_on_fail: bool = None, + icheck_term_pair: int = None, + interface_idx: int = None, + generate_structures: bool = None, + seed: int = None, + verbose: int = None, + exit_code: int = None, + return_exit_code: bool = False, + calc = None + ): + """ + generate__binding__artemis_gen_type(self[, surface_lw, \ + surface_up, thickness_lw, thickness_up, num_layers_lw, num_layers_up, \ + print_lattice_match_info, print_termination_info, print_shift_info, \ + break_on_fail, icheck_term_pair, interface_idx, generate_structures, seed, \ + verbose, exit_code]) + + + Defined at \ + ../src/fortran/lib/mod_intf_generator.f90 \ + lines 315-1111 + + Parameters + ---------- + this : Artemis_generator_Type + surface_lw : int + surface_up : int + thickness_lw : float + thickness_up : float + num_layers_lw : int + num_layers_up : int + print_lattice_match_info : bool + print_termination_info : bool + print_shift_info : bool + break_on_fail : bool + icheck_term_pair : int + interface_idx : int + generate_structures : bool + seed : int + verbose : int + exit_code : int + + """ + + exit_code = 0 + structures = None + + exit_code = _artemis.f90wrap_intf_gen__generate__binding__agt(this=self._handle, \ + surface_lw=surface_lw, surface_up=surface_up, + thickness_lw=thickness_lw, thickness_up=thickness_up, + num_layers_lw=num_layers_lw, num_layers_up=num_layers_up, \ + reduce_matches=reduce_matches, \ + print_lattice_match_info=print_lattice_match_info, \ + print_termination_info=print_termination_info, \ + print_shift_info=print_shift_info, break_on_fail=break_on_fail, \ + icheck_term_pair=icheck_term_pair, interface_idx=interface_idx, \ + generate_structures=generate_structures, seed=seed, verbose=verbose + ) + if ( exit_code != 0 and exit_code != None ) and not return_exit_code: + raise RuntimeError(f"Interface generation failed (exit code {exit_code})") + + structures = self.get_structures(calc) + if return_exit_code: + return structures, exit_code + return structures + + def regenerate( + self, + structure: Atoms | Geom_Rw.basis, + interface_location: float | None = None, + print_shift_info: bool = None, + seed: int = None, + verbose: int = None, + return_exit_code: bool = False, + calc = None + ): + """ + restart__binding__artemis_gen_type(self, basis[, \ + interface_location, print_shift_info, seed]) + + + Defined at \ + ../src/fortran/lib/mod_intf_generator.f90 \ + lines 202-297 + + Parameters + ---------- + this : Artemis_generator_Type + basis : Basis_Type + interface_location : float array + print_shift_info : bool + seed : int + + --------------------------------------------------------------------------- + Set the random seed + --------------------------------------------------------------------------- + """ + exit_code = 0 + structures = None + num_structures_old = self.num_structures + + # check if host is ase.Atoms object or a Fortran derived type basis_type + if isinstance(structure, Atoms): + structure = geom_rw.basis(atoms=structure) + + exit_code = _artemis.f90wrap_intf_gen__regenerate__binding__agt(this=self._handle, \ + structure=structure._handle, interface_location=interface_location, \ + print_shift_info=print_shift_info, seed=seed, verbose=verbose) + + if ( exit_code != 0 and exit_code != None ) and not return_exit_code: + raise RuntimeError(f"Interface generation failed (exit code {exit_code})") + + num_structures_generated = self.num_structures - num_structures_old + structures = self.get_structures(calc)[-num_structures_generated:] + if return_exit_code: + return structures, exit_code + return structures + + def clear_structures(self): + """ + Clear the generated structures from the generator. + + """ + _artemis.f90wrap_intf_gen__clear_structures__binding__agt(this=self._handle) + + def get_structures(self, calculator=None): + """ + Get the generated structures as a list of ASE Atoms objects. + + Parameters: + calculator (ASE calculator): + The calculator to use for the generated structures. + """ + atoms = [] + for structure in self.structures: + atoms.append(structure.toase(calculator)) + return atoms + + @property + def num_structures(self): + """ + The number of generated structures currently stored in the generator. + """ + return _artemis.f90wrap_artemis_gen_type__get__num_structures(self._handle) + + @num_structures.setter + def num_structures(self, num_structures): + _artemis.f90wrap_artemis_gen_type__set__num_structures(self._handle, \ + num_structures) + + @property + def max_num_structures(self): + """ + The maximum number of generated structures that can be stored in the generator. + """ + return _artemis.f90wrap_artemis_gen_type__get__num_structures(self._handle) + + @max_num_structures.setter + def max_num_structures(self, max_num_structures): + _artemis.f90wrap_artemis_gen_type__set__max_num_structures(self._handle, \ + max_num_structures) + + @property + def structure_lw(self): + """ + Element structure_lw ftype=type(basis_type) pytype=Basis_Type + + + Defined at \ + ../fortran/lib/mod_intf_generator.f90 \ + line 32 + + """ + structure_lw_handle = \ + _artemis.f90wrap_artemis_gen_type__get__structure_lw(self._handle) + if tuple(structure_lw_handle) in self._objs: + structure_lw = self._objs[tuple(structure_lw_handle)] + else: + structure_lw = geom_rw.basis.from_handle(structure_lw_handle) + self._objs[tuple(structure_lw_handle)] = structure_lw + return structure_lw + + @structure_lw.setter + def structure_lw(self, structure_lw): + structure_lw = structure_lw._handle + _artemis.f90wrap_artemis_gen_type__set__structure_lw(self._handle, \ + structure_lw) + + @property + def structure_up(self): + """ + Element structure_up ftype=type(basis_type) pytype=Basis_Type + + + Defined at \ + ../fortran/lib/mod_intf_generator.f90 \ + line 32 + + """ + structure_up_handle = \ + _artemis.f90wrap_artemis_gen_type__get__structure_up(self._handle) + if tuple(structure_up_handle) in self._objs: + structure_up = self._objs[tuple(structure_up_handle)] + else: + structure_up = geom_rw.basis.from_handle(structure_up_handle) + self._objs[tuple(structure_up_handle)] = structure_up + return structure_up + + @structure_up.setter + def structure_up(self, structure_up): + structure_up = structure_up._handle + _artemis.f90wrap_artemis_gen_type__set__structure_up(self._handle, \ + structure_up) + + @property + def elastic_tensor_lw(self): + """ + Element elastic_tensor_lw ftype=real(real32) pytype=float + + + Defined at \ + ../fortran/lib/mod_intf_generator.f90 \ + line 34 + + """ + array_ndim, array_type, array_shape, array_handle = \ + _artemis.f90wrap_artemis_gen_type__array__elastic_co4c3f(self._handle) + + if array_handle == 0: + return None + + if array_handle in self._arrays: + elastic_tensor_lw = self._arrays[array_handle] + else: + elastic_tensor_lw = \ + f90wrap.runtime.get_array(f90wrap.runtime.sizeof_fortran_t, + self._handle, + _artemis.f90wrap_artemis_gen_type__array__elastic_co4c3f) + self._arrays[array_handle] = elastic_tensor_lw + return elastic_tensor_lw + + @elastic_tensor_lw.setter + def elastic_tensor_lw(self, elastic_tensor_lw): + self.elastic_tensor_lw[...] = elastic_tensor_lw + + @property + def elastic_tensor_up(self): + """ + Element elastic_tensor_up ftype=real(real32) pytype=float + + + Defined at \ + ../fortran/lib/mod_intf_generator.f90 \ + line 34 + + """ + array_ndim, array_type, array_shape, array_handle = \ + _artemis.f90wrap_artemis_gen_type__array__elastic_coedb6(self._handle) + + if array_handle == 0: + return None + + if array_handle in self._arrays: + elastic_tensor_up = self._arrays[array_handle] + else: + elastic_tensor_up = \ + f90wrap.runtime.get_array(f90wrap.runtime.sizeof_fortran_t, + self._handle, + _artemis.f90wrap_artemis_gen_type__array__elastic_coedb6) + self._arrays[array_handle] = elastic_tensor_up + return elastic_tensor_up + + @elastic_tensor_up.setter + def elastic_tensor_up(self, elastic_tensor_up): + self.elastic_tensor_up[...] = elastic_tensor_up + + @property + def use_pricel_lw(self): + """ + Element use_pricel_lw ftype=logical pytype=bool + + + Defined at \ + ../fortran/lib/mod_intf_generator.f90 \ + line 36 + + """ + return \ + _artemis.f90wrap_artemis_gen_type__get__use_pricel_lw(self._handle) + + @use_pricel_lw.setter + def use_pricel_lw(self, use_pricel_lw): + _artemis.f90wrap_artemis_gen_type__set__use_pricel_lw(self._handle, \ + use_pricel_lw) + + @property + def use_pricel_up(self): + """ + Element use_pricel_up ftype=logical pytype=bool + + + Defined at \ + ../fortran/lib/mod_intf_generator.f90 \ + line 36 + + """ + return \ + _artemis.f90wrap_artemis_gen_type__get__use_pricel_up(self._handle) + + @use_pricel_up.setter + def use_pricel_up(self, use_pricel_up): + _artemis.f90wrap_artemis_gen_type__set__use_pricel_up(self._handle, \ + use_pricel_up) + + @property + def miller_lw(self): + """ + Element miller_lw ftype=integer pytype=int + + + Defined at \ + ../fortran/lib/mod_intf_generator.f90 \ + line 38 + + """ + array_ndim, array_type, array_shape, array_handle = \ + _artemis.f90wrap_artemis_gen_type__array__miller_lw(self._handle) + if array_handle in self._arrays: + miller_lw = self._arrays[array_handle] + else: + miller_lw = f90wrap.runtime.get_array(f90wrap.runtime.sizeof_fortran_t, + self._handle, + _artemis.f90wrap_artemis_gen_type__array__miller_lw) + self._arrays[array_handle] = miller_lw + return miller_lw + + @miller_lw.setter + def miller_lw(self, miller_lw): + self.miller_lw[...] = miller_lw + + @property + def miller_up(self): + """ + Element miller_up ftype=integer pytype=int + + + Defined at \ + ../fortran/lib/mod_intf_generator.f90 \ + line 38 + + """ + array_ndim, array_type, array_shape, array_handle = \ + _artemis.f90wrap_artemis_gen_type__array__miller_up(self._handle) + if array_handle in self._arrays: + miller_up = self._arrays[array_handle] + else: + miller_up = f90wrap.runtime.get_array(f90wrap.runtime.sizeof_fortran_t, + self._handle, + _artemis.f90wrap_artemis_gen_type__array__miller_up) + self._arrays[array_handle] = miller_up + return miller_up + + @miller_up.setter + def miller_up(self, miller_up): + self.miller_up[...] = miller_up + + @property + def is_layered_lw(self): + """ + Element is_layered_lw ftype=logical pytype=bool + + + Defined at \ + ../fortran/lib/mod_intf_generator.f90 \ + line 40 + + """ + return \ + _artemis.f90wrap_artemis_gen_type__get__is_layered_lw(self._handle) + + @is_layered_lw.setter + def is_layered_lw(self, is_layered_lw): + _artemis.f90wrap_artemis_gen_type__set__is_layered_lw(self._handle, \ + is_layered_lw) + + @property + def is_layered_up(self): + """ + Element is_layered_up ftype=logical pytype=bool + + + Defined at \ + ../fortran/lib/mod_intf_generator.f90 \ + line 40 + + """ + return \ + _artemis.f90wrap_artemis_gen_type__get__is_layered_up(self._handle) + + @is_layered_up.setter + def is_layered_up(self, is_layered_up): + _artemis.f90wrap_artemis_gen_type__set__is_layered_up(self._handle, \ + is_layered_up) + + @property + def ludef_is_layered_lw(self): + """ + Element ludef_is_layered_lw ftype=logical pytype=bool + + + Defined at \ + ../fortran/lib/mod_intf_generator.f90 \ + line 42 + + """ + return \ + _artemis.f90wrap_artemis_gen_type__get__ludef_is_lay4aa6(self._handle) + + @ludef_is_layered_lw.setter + def ludef_is_layered_lw(self, ludef_is_layered_lw): + _artemis.f90wrap_artemis_gen_type__set__ludef_is_lay87a5(self._handle, \ + ludef_is_layered_lw) + + @property + def ludef_is_layered_up(self): + """ + Element ludef_is_layered_up ftype=logical pytype=bool + + + Defined at \ + ../fortran/lib/mod_intf_generator.f90 \ + line 42 + + """ + return \ + _artemis.f90wrap_artemis_gen_type__get__ludef_is_lay60fd(self._handle) + + @ludef_is_layered_up.setter + def ludef_is_layered_up(self, ludef_is_layered_up): + _artemis.f90wrap_artemis_gen_type__set__ludef_is_laye6e4(self._handle, \ + ludef_is_layered_up) + + @property + def shift_method(self): + """ + Element shift_method ftype=integer pytype=int + + + Defined at \ + ../src/fortran/lib/mod_intf_generator.f90 \ + line 31 + + """ + return \ + _artemis.f90wrap_artemis_gen_type__get__shift_method(self._handle) + + @shift_method.setter + def shift_method(self, shift_method): + _artemis.f90wrap_artemis_gen_type__set__shift_method(self._handle, \ + shift_method) + + @property + def num_shifts(self): + """ + Element num_shifts ftype=integer pytype=int + + + Defined at \ + ../src/fortran/lib/mod_intf_generator.f90 \ + line 33 + + """ + return \ + _artemis.f90wrap_artemis_gen_type__get__num_shifts(self._handle) + + @num_shifts.setter + def num_shifts(self, num_shifts): + _artemis.f90wrap_artemis_gen_type__set__num_shifts(self._handle, \ + num_shifts) + + @property + def shifts(self): + """ + Element shifts ftype=real(real32) pytype=float + + + Defined at \ + ../src/fortran/lib/mod_intf_generator.f90 \ + line 35 + + """ + array_ndim, array_type, array_shape, array_handle = \ + _artemis.f90wrap_artemis_gen_type__array__shifts(self._handle) + + if array_handle == 0: + return None + + if array_handle in self._arrays: + shifts = self._arrays[array_handle] + else: + shifts = f90wrap.runtime.get_array(f90wrap.runtime.sizeof_fortran_t, + self._handle, + _artemis.f90wrap_artemis_gen_type__array__shifts) + self._arrays[array_handle] = shifts + return shifts + + @shifts.setter + def shifts(self, shifts): + self.shifts[...] = shifts + + @property + def interface_depth(self): + """ + Element interface_depth ftype=real(real32) pytype=float + + + Defined at \ + ../src/fortran/lib/mod_intf_generator.f90 \ + line 37 + + """ + return \ + _artemis.f90wrap_artemis_gen_type__get__interface_depth(self._handle) + + @interface_depth.setter + def interface_depth(self, interface_depth): + _artemis.f90wrap_artemis_gen_type__set__interface_depth(self._handle, \ + interface_depth) + + @property + def separation_scale(self): + """ + Element separation_scale ftype=real(real32) pytype=float + + + Defined at \ + ../src/fortran/lib/mod_intf_generator.f90 \ + line 39 + + """ + return \ + _artemis.f90wrap_artemis_gen_type__get__separation_scale(self._handle) + + @separation_scale.setter + def separation_scale(self, separation_scale): + _artemis.f90wrap_artemis_gen_type__set__separation_scale(self._handle, \ + separation_scale) + + @property + def depth_method(self): + """ + Element depth_method ftype=integer pytype=int + + + Defined at \ + ../src/fortran/lib/mod_intf_generator.f90 \ + line 41 + + """ + return \ + _artemis.f90wrap_artemis_gen_type__get__depth_method(self._handle) + + @depth_method.setter + def depth_method(self, depth_method): + _artemis.f90wrap_artemis_gen_type__set__depth_method(self._handle, \ + depth_method) + + def init_array_structure_data(self): + self.structure_data = f90wrap.runtime.FortranDerivedTypeArray(self, + _artemis.f90wrap_artemis_gen_type__array_getitem__structure_data, + _artemis.f90wrap_artemis_gen_type__array_setitem__structure_data, + _artemis.f90wrap_artemis_gen_type__array_len__structure_data, + """ + Element structure_data ftype=type(struc_data_type) pytype=Struc_Data_Type + + + Defined at \ + ../fortran/lib/mod_generator.f90 line \ + 56 + + """, Misc_Types.struc_data_type) + return self.structure_data + + @property + def swap_method(self): + """ + Element swap_method ftype=integer pytype=int + + + Defined at \ + ../src/fortran/lib/mod_intf_generator.f90 \ + line 45 + + """ + return \ + _artemis.f90wrap_artemis_gen_type__get__swap_method(self._handle) + + @swap_method.setter + def swap_method(self, swap_method): + _artemis.f90wrap_artemis_gen_type__set__swap_method(self._handle, \ + swap_method) + + @property + def num_swaps(self): + """ + Element num_swaps ftype=integer pytype=int + + + Defined at \ + ../src/fortran/lib/mod_intf_generator.f90 \ + line 47 + + """ + return \ + _artemis.f90wrap_artemis_gen_type__get__num_swaps(self._handle) + + @num_swaps.setter + def num_swaps(self, num_swaps): + _artemis.f90wrap_artemis_gen_type__set__num_swaps(self._handle, \ + num_swaps) + + @property + def swap_density(self): + """ + Element swap_density ftype=real(real32) pytype=float + + + Defined at \ + ../src/fortran/lib/mod_intf_generator.f90 \ + line 49 + + """ + return \ + _artemis.f90wrap_artemis_gen_type__get__swap_density(self._handle) + + @swap_density.setter + def swap_density(self, swap_density): + _artemis.f90wrap_artemis_gen_type__set__swap_density(self._handle, \ + swap_density) + + @property + def swap_depth(self): + """ + Element swap_depth ftype=real(real32) pytype=float + + + Defined at \ + ../src/fortran/lib/mod_intf_generator.f90 \ + line 51 + + """ + return \ + _artemis.f90wrap_artemis_gen_type__get__swap_depth(self._handle) + + @swap_depth.setter + def swap_depth(self, swap_depth): + _artemis.f90wrap_artemis_gen_type__set__swap_depth(self._handle, \ + swap_depth) + + @property + def swap_sigma(self): + """ + Element swap_sigma ftype=real(real32) pytype=float + + + Defined at \ + ../src/fortran/lib/mod_intf_generator.f90 \ + line 53 + + """ + return \ + _artemis.f90wrap_artemis_gen_type__get__swap_sigma(self._handle) + + @swap_sigma.setter + def swap_sigma(self, swap_sigma): + _artemis.f90wrap_artemis_gen_type__set__swap_sigma(self._handle, \ + swap_sigma) + + @property + def require_mirror_swaps(self): + """ + Element require_mirror_swaps ftype=logical pytype=bool + + + Defined at \ + ../src/fortran/lib/mod_intf_generator.f90 \ + line 55 + + """ + return \ + _artemis.f90wrap_artemis_gen_type__get__require_mirror_swaps(self._handle) + + @require_mirror_swaps.setter + def require_mirror_swaps(self, require_mirror_swaps): + _artemis.f90wrap_artemis_gen_type__set__require_mirror_swaps(self._handle, \ + require_mirror_swaps) + + @property + def match_method(self): + """ + Element match_method ftype=integer pytype=int + + + Defined at \ + ../src/fortran/lib/mod_intf_generator.f90 \ + line 57 + + """ + return \ + _artemis.f90wrap_artemis_gen_type__get__match_method(self._handle) + + @match_method.setter + def match_method(self, match_method): + _artemis.f90wrap_artemis_gen_type__set__match_method(self._handle, \ + match_method) + + @property + def max_num_matches(self): + """ + Element max_num_matches ftype=integer pytype=int + + + Defined at \ + ../src/fortran/lib/mod_intf_generator.f90 \ + line 58 + + """ + return \ + _artemis.f90wrap_artemis_gen_type__get__max_num_matches(self._handle) + + @max_num_matches.setter + def max_num_matches(self, max_num_matches): + _artemis.f90wrap_artemis_gen_type__set__max_num_matches(self._handle, \ + max_num_matches) + + @property + def max_num_terms(self): + """ + Element max_num_terms ftype=integer pytype=int + + + Defined at \ + ../src/fortran/lib/mod_intf_generator.f90 \ + line 59 + + """ + return \ + _artemis.f90wrap_artemis_gen_type__get__max_num_terms(self._handle) + + @max_num_terms.setter + def max_num_terms(self, max_num_terms): + _artemis.f90wrap_artemis_gen_type__set__max_num_terms(self._handle, \ + max_num_terms) + + @property + def max_num_planes(self): + """ + Element max_num_planes ftype=integer pytype=int + + + Defined at \ + ../src/fortran/lib/mod_intf_generator.f90 \ + line 60 + + """ + return \ + _artemis.f90wrap_artemis_gen_type__get__max_num_planes(self._handle) + + @max_num_planes.setter + def max_num_planes(self, max_num_planes): + _artemis.f90wrap_artemis_gen_type__set__max_num_planes(self._handle, \ + max_num_planes) + + @property + def compensate_normal(self): + """ + Element compensate_normal ftype=logical pytype=bool + + + Defined at \ + ../src/fortran/lib/mod_intf_generator.f90 \ + line 61 + + """ + return \ + _artemis.f90wrap_artemis_gen_type__get__compensate_normal(self._handle) + + @compensate_normal.setter + def compensate_normal(self, compensate_normal): + _artemis.f90wrap_artemis_gen_type__set__compensate_normal(self._handle, \ + compensate_normal) + + @property + def bondlength_cutoff(self): + """ + Element bondlength_cutoff ftype=real(real32) pytype=float + + + Defined at \ + ../src/fortran/lib/mod_intf_generator.f90 \ + line 65 + + """ + return \ + _artemis.f90wrap_artemis_gen_type__get__bondlength_cutoff(self._handle) + + @bondlength_cutoff.setter + def bondlength_cutoff(self, bondlength_cutoff): + _artemis.f90wrap_artemis_gen_type__set__bondlength_cutoff(self._handle, \ + bondlength_cutoff) + + @property + def layer_separation_cutoff(self): + """ + Element layer_separation_cutoff ftype=real(real32) pytype=float + + + Defined at \ + ../src/fortran/lib/mod_intf_generator.f90 \ + line 66 + + """ + array_ndim, array_type, array_shape, array_handle = \ + _artemis.f90wrap_artemis_gen_type__array__layer_separation_cutoff(self._handle) + if array_handle in self._arrays: + layer_separation_cutoff = self._arrays[array_handle] + else: + layer_separation_cutoff = \ + f90wrap.runtime.get_array(f90wrap.runtime.sizeof_fortran_t, + self._handle, + _artemis.f90wrap_artemis_gen_type__array__layer_separation_cutoff) + self._arrays[array_handle] = layer_separation_cutoff + return layer_separation_cutoff + + @layer_separation_cutoff.setter + def layer_separation_cutoff(self, layer_separation_cutoff): + self.layer_separation_cutoff[...] = layer_separation_cutoff + + def _init_array_structures(self): + """ + Initialise the structures array. + + It is not recommended to use this function directly. Use the `structures` property instead. + """ + self.structures = f90wrap.runtime.FortranDerivedTypeArray(self, + _artemis.f90wrap_artemis_gen_type__array_getitem__structures, + _artemis.f90wrap_artemis_gen_type__array_setitem__structures, + _artemis.f90wrap_artemis_gen_type__array_len__structures, + """ + Element items ftype=type(basis_type) pytype=basis + + + Defined at ../src/lib/mod_generator.f90 line \ + 29 + + """, Geom_Rw.basis) + return self.structures + + def __str__(self): + ret = ['{\n'] + ret.append(' num_structures : ') + ret.append(repr(self.num_structures)) + ret.append(',\n max_num_structures : ') + ret.append(repr(self.max_num_structures)) + ret.append('\n structure_lw : ') + ret.append(repr(self.structure_lw)) + ret.append(',\n structure_up : ') + ret.append(repr(self.structure_up)) + ret.append(',\n elastic_tensor_lw : ') + ret.append(repr(self.elastic_tensor_lw)) + ret.append(',\n elastic_tensor_up : ') + ret.append(repr(self.elastic_tensor_up)) + ret.append(',\n use_pricel_lw : ') + ret.append(repr(self.use_pricel_lw)) + ret.append(',\n use_pricel_up : ') + ret.append(repr(self.use_pricel_up)) + ret.append(',\n miller_lw : ') + ret.append(repr(self.miller_lw)) + ret.append(',\n miller_up : ') + ret.append(repr(self.miller_up)) + ret.append(',\n is_layered_lw : ') + ret.append(repr(self.is_layered_lw)) + ret.append(',\n is_layered_up : ') + ret.append(repr(self.is_layered_up)) + ret.append(',\n ludef_is_layered_lw : ') + ret.append(repr(self.ludef_is_layered_lw)) + ret.append(',\n ludef_is_layered_up : ') + ret.append(repr(self.ludef_is_layered_up)) + ret.append('\n shift_method : ') + ret.append(repr(self.shift_method)) + ret.append(',\n num_shifts : ') + ret.append(repr(self.num_shifts)) + ret.append(',\n shifts : ') + ret.append(repr(self.shifts)) + ret.append(',\n interface_depth : ') + ret.append(repr(self.interface_depth)) + ret.append(',\n separation_scale : ') + ret.append(repr(self.separation_scale)) + ret.append(',\n depth_method : ') + ret.append(repr(self.depth_method)) + ret.append(',\n swap_method : ') + ret.append(repr(self.swap_method)) + ret.append(',\n num_swaps : ') + ret.append(repr(self.num_swaps)) + ret.append(',\n swap_density : ') + ret.append(repr(self.swap_density)) + ret.append(',\n swap_depth : ') + ret.append(repr(self.swap_depth)) + ret.append(',\n swap_sigma : ') + ret.append(repr(self.swap_sigma)) + ret.append(',\n require_mirror_swaps : ') + ret.append(repr(self.require_mirror_swaps)) + ret.append(',\n match_method : ') + ret.append(repr(self.match_method)) + ret.append(',\n max_num_matches : ') + ret.append(repr(self.max_num_matches)) + ret.append(',\n max_num_terms : ') + ret.append(repr(self.max_num_terms)) + ret.append(',\n max_num_planes : ') + ret.append(repr(self.max_num_planes)) + ret.append(',\n compensate_normal : ') + ret.append(repr(self.compensate_normal)) + ret.append(',\n bondlength_cutoff : ') + ret.append(repr(self.bondlength_cutoff)) + ret.append(',\n layer_separation_cutoff : ') + ret.append(repr(self.layer_separation_cutoff)) + ret.append(',\n structures : ') + ret.append(repr(self.structures)) + ret.append('}') + return ''.join(ret) + + _dt_array_initialisers = [_init_array_structures] + + + _dt_array_initialisers = [] + + +generator = Generator() + +class Artemis(f90wrap.runtime.FortranModule): + """ + Module artemis + + + Defined at ../src/fortran/artemis.f90 lines \ + 1-4 + + """ + pass + _dt_array_initialisers = [] + + +artemis = Artemis() + diff --git a/tests/generate_interface/DCHECK/D01/DSHIFT/shift_vals.txt b/src/artemis/cli/__init__.py similarity index 100% rename from tests/generate_interface/DCHECK/D01/DSHIFT/shift_vals.txt rename to src/artemis/cli/__init__.py diff --git a/src/artemis/cli/main.py b/src/artemis/cli/main.py new file mode 100644 index 0000000..51bb913 --- /dev/null +++ b/src/artemis/cli/main.py @@ -0,0 +1,9 @@ +import os +import subprocess +import sys + +def main(): + this_dir = os.path.dirname(__file__) + package_root = os.path.abspath(os.path.join(this_dir, '..')) # go up from cli/ + exe_path = os.path.join(package_root, 'bin', 'artemis_executable') + subprocess.run([exe_path] + sys.argv[1:]) \ No newline at end of file diff --git a/src/default_infile.f90 b/src/default_infile.f90 deleted file mode 100644 index ddf1817..0000000 --- a/src/default_infile.f90 +++ /dev/null @@ -1,96 +0,0 @@ -!!!############################################################################# -!!! module to write example input file -!!!############################################################################# -module infile_print - implicit none - - -!!!updated 2022/04/04 - - -contains -!!!############################################################################# -!!! print example.in -!!!############################################################################# - subroutine print_default_file(file) - implicit none - integer :: UNIT - character(*), optional :: file - - UNIT=0 - if(present(file))then - UNIT=20 - open(unit=UNIT,file=file) - end if - - write(UNIT,'("SETTINGS")') - write(UNIT,'(2X,"TASK = 1")') - write(UNIT,'(2X,"RESTART = 0")') - write(UNIT,'(2X,"STRUC1_FILE = POSCAR1 ! lower structure/interface structure")') - write(UNIT,'(2X,"STRUC2_FILE = POSCAR2 ! upper structure (not used if RESTART > 0)")') - write(UNIT,'(2X,"MASTER_DIR = DINTERFACES")') - write(UNIT,'(2X,"SUBDIR_PREFIX = D")') - write(UNIT,'(2X,"IPRINT = 0")') - write(UNIT,'(2X,"CLOCK = ! taken from the time clock by default")') - write(UNIT,'("END SETTINGS")') - write(UNIT,*) - write(UNIT,*) - write(UNIT,'("CELL_EDITS")') - write(UNIT,'(2X,"LSURF_GEN = T")') - write(UNIT,'(2X,"MILLER_PLANE = 1 2 1")') - write(UNIT,'(2X,"SLAB_THICKNESS = 6")') - write(UNIT,'("END CELL_EDITS")') - write(UNIT,*) - write(UNIT,*) - write(UNIT,'("INTERFACES")') - write(UNIT,'(2X,"LGEN_INTERFACES = T ! generate interfaces")') - write(UNIT,'(2X,"IMATCH = 0 ! interface matching method")') - write(UNIT,'(2X,"NINTF = 100 ! max number of interfaces")') - write(UNIT,'(2X,"NMATCH = 5 ! max number of lattice matches")') - write(UNIT,'(2X,"TOL_VEC = 5.D0 ! max vector tolerance (in percent %)")') - write(UNIT,'(2X,"TOL_ANG = 1.D0 ! max angle tolerance (in degrees (°))")') - write(UNIT,'(2X,"TOL_AREA = 10.D0 ! max area tolerance (in percent %)")') - write(UNIT,'(2X,"TOL_MAXFIND = 100 ! max number of good fits to find per plane")') - write(UNIT,'(2X,"TOL_MAXSIZE = 10 ! max increase of any lattice vector")') - write(UNIT,'(2X,"LW_USE_PRICEL = T ! extract and use the primitive cell of lower")') - write(UNIT,'(2X,"UP_USE_PRICEL = T ! extract and use the primitive cell of upper")') - write(UNIT,*) - write(UNIT,'(2X,"NMILLER = 10 ! number of Miller planes to consider")') - write(UNIT,'(2X,"LW_MILLER = ! written as a miller plane, e.g. 0 0 1")') - write(UNIT,'(2X,"UP_MILLER = ! written as a miller plane, e.g. 0 0 1")') - write(UNIT,*) - write(UNIT,'(2X,"LW_SLAB_THICKNESS = 3 ! thickness of lower material")') - write(UNIT,'(2X,"UP_SLAB_THICKNESS = 3 ! thickness of upper material")') - write(UNIT,'(2X,"NTERM = 5 ! max number of terminations per material per match")') - write(UNIT,'(2X,"LW_SURFACE = ! surface to force for interface generation")') - write(UNIT,'(2X,"UP_SURFACE = ! surface to force for interface generation")') - write(UNIT,*) - write(UNIT,'(2X,"SHIFTDIR = DSHIFT ! shift directory name")') - write(UNIT,'(2X,"ISHIFT = 4 ! shifting method")') - write(UNIT,'(2X,"NSHIFT = 5 ! number of shifts to apply")') - write(UNIT,'(2X,"C_SCALE = 1.D0 ! interface-separation scaling factor")') - write(UNIT,*) - write(UNIT,'(2X,"SWAPDIR = DSWAP ! swap directory name")') - write(UNIT,'(2X,"ISWAP = 0 ! swapping method")') - write(UNIT,'(2X,"NSWAP = 5 ! number of swap structures generated per interface")') - write(UNIT,'(2X,"SWAP_DENSITY = 5.D-2 ! intermixing area density")') - write(UNIT,*) - write(UNIT,'(2X,"LSURF_GEN = F ! generate surfaces of a plane")') - write(UNIT,'(2X,"LPRINT_TERMS = F ! prints all found terminations")') - write(UNIT,'(2X,"LPRINT_MATCHES = F ! prints all found lattice matches")') - write(UNIT,'("END INTERFACES")') - write(UNIT,*) - !write(UNIT,*) - !write(UNIT,'("DEFECTS")') - !write(UNIT,'("! NOT CURRENTLY IMPLEMENTED")') - !write(UNIT,'("END DEFECTS")') - - - if(UNIT.ne.0) close(UNIT) - - - end subroutine print_default_file -!!!############################################################################# - - -end module infile_print diff --git a/src/fortran/artemis.f90 b/src/fortran/artemis.f90 new file mode 100644 index 0000000..9758949 --- /dev/null +++ b/src/fortran/artemis.f90 @@ -0,0 +1,14 @@ +module artemis + use artemis__geom_rw, only: basis_type, & + geom_write, geom_read + use artemis__structure_cache, only: & + store_last_generated_structures, & + retrieve_last_generated_structures + use artemis__interface_identifier, only: intf_info_type + use artemis__generator, only: artemis_generator_type + implicit none + + + ! allow the identify_interface procedure to be called externally + +end module artemis \ No newline at end of file diff --git a/src/fortran/lib/mod_cache.f90 b/src/fortran/lib/mod_cache.f90 new file mode 100644 index 0000000..d9fb806 --- /dev/null +++ b/src/fortran/lib/mod_cache.f90 @@ -0,0 +1,31 @@ +module artemis__structure_cache + use artemis__geom_rw, only: basis_type + implicit none + + private + public :: store_last_generated_structures, retrieve_last_generated_structures + + type(basis_type), allocatable, dimension(:), save :: cached_structures + +contains + + subroutine store_last_generated_structures(structures) + implicit none + type(basis_type), intent(in), allocatable :: structures(:) + if (allocated(cached_structures)) deallocate(cached_structures) + allocate(cached_structures(size(structures))) + cached_structures = structures + end subroutine store_last_generated_structures + + function retrieve_last_generated_structures() result(structures) + implicit none + type(basis_type), allocatable :: structures(:) + if (.not.allocated(cached_structures)) then + allocate(structures(0)) + else + allocate(structures(size(cached_structures))) + structures = cached_structures + end if + end function retrieve_last_generated_structures + +end module artemis__structure_cache diff --git a/src/fortran/lib/mod_constants.f90 b/src/fortran/lib/mod_constants.f90 new file mode 100644 index 0000000..88bca78 --- /dev/null +++ b/src/fortran/lib/mod_constants.f90 @@ -0,0 +1,14 @@ +module artemis__constants + implicit none + integer, parameter, public :: real32 = Selected_real_kind(6,37) + real(real32), parameter, public :: k_b = 1.3806503e-23_real32 + real(real32), parameter, public :: hbar = 1.05457148e-34_real32 + real(real32), parameter, public :: h = 6.626068e-34_real32 + real(real32), parameter, public :: atomic_mass=1.67262158e-27_real32 + real(real32), parameter, public :: avogadros=6.022e23_real32 + real(real32), parameter, public :: bohrtoang=0.529177249_real32 + real(real32), parameter, public :: pi = 4._real32*atan(1._real32) + real(real32), parameter, public :: INF = huge(0._real32) + integer, public :: ierror = -1 + real(real32), parameter, public :: tolerance = 1.E-6_real32 +end MODULE artemis__constants diff --git a/src/fortran/lib/mod_generator.f90 b/src/fortran/lib/mod_generator.f90 new file mode 100644 index 0000000..d456012 --- /dev/null +++ b/src/fortran/lib/mod_generator.f90 @@ -0,0 +1,2595 @@ +!!!############################################################################# +!!! INTERFACES CARD SUBROUTINES +!!! Code written by Ned Thaddeus Taylor and Isiah Edward Mikel Rudkin +!!! Code part of the ARTEMIS group (Hepplestone research group). +!!! Think Hepplestone, think HRG. +!!!############################################################################# +module artemis__generator + use artemis__constants, only: real32, pi + use artemis__misc, only: to_lower, to_upper + use artemis__misc_types, only: abstract_artemis_generator_type, & + latmatch_type, tol_type, struc_data_type + use artemis__geom_rw, only: basis_type + use lat_compare, only: lattice_matching, cyc_lat1 + use artemis__io_utils, only: err_abort, print_warning, stop_program + use artemis__io_utils_extd, only: err_abort_print_struc + use misc_linalg, only: uvec,modu,get_area,inverse,cross + use artemis__interface_identifier, only: intf_info_type,& + get_interface,get_layered_axis,gen_DON + use artemis__geom_utils, only: planecutter, primitive_lat, ortho_axis,& + shift_region, set_vacuum, transformer, shifter, reducer, & + get_min_bulk_bond, get_min_bond, get_shortest_bond, bond_type, & + share_strain_scalar, share_strain_tensor, MATNORM, & + basis_stack, compare_stoichiometry, get_primitive_cell + use artemis__sym, only: confine_type, gldfnd + use artemis__terminations, only: get_termination_info, term_arr_type, & + set_layer_tol, build_slab_supercell, cut_slab_to_height + use swapping, only: rand_swapper + use shifting !!! CHANGE TO SHIFTER? + implicit none + + + private + + public :: artemis_generator_type + + + type, extends(abstract_artemis_generator_type) :: artemis_generator_type + !! Interface generator type + type(basis_type) :: structure_lw, structure_up + !! Lower and upper bulk structures + real(real32), dimension(:,:), allocatable :: elastic_tensor_lw, elastic_tensor_up + !! Elastic constants for the lower and upper bulk structures + logical :: use_pricel_lw = .true., use_pricel_up = .true. + !! Use primitive cell for lower and upper bulk structures + logical :: require_stoichiometry_lw = .false., & + require_stoichiometry_up = .false. + !! Boolean whether to require stoichiometry for the lower and upper bulk structures + + integer, dimension(3) :: miller_lw = [ 0, 0, 0 ], miller_up = [ 0, 0, 0 ] + !! Miller indices for the lower and upper bulk structures + logical :: is_layered_lw = .false., is_layered_up = .false. + !! Boolean whether the lower and upper bulk structures are layered + logical :: ludef_is_layered_lw = .false., ludef_is_layered_up = .false. + !! Boolean whether the user defined whether to use layered structures + + integer :: shift_method = 4 + !! Shift method + integer :: num_shifts = 5 + !! Number of shifts per lattice match + real(real32), dimension(:,:), allocatable :: shifts + !! Shift values + real(real32) :: interface_depth = 1.5_real32 + !! Interface depth + real(real32) :: separation_scale = 1._real32 + !! Separation scale + integer :: depth_method = 0 + !! Method for determining the depth to which consider atoms from interface + + type(struc_data_type), dimension(:), allocatable :: structure_data + !! Structure data + + integer :: swap_method = 0 + !! Swap method + integer :: num_swaps = 0 + !! Number of swaps per shifted interface + real(real32) :: swap_density = 5.E-2_real32 + !! Swap density + real(real32) :: swap_depth = 3._real32 + !! Swap depth + real(real32) :: swap_sigma = -1._real32 + !! Swap sigma + logical :: require_mirror_swaps = .true. + !! Require mirror swaps + + integer :: match_method = 0 + !! Match method + integer :: max_num_matches = 5 + !! Maximum number of matches + integer :: max_num_terms = 5 + !! Maximum number of terminations + integer :: max_num_planes = 10 + !! Maximum number of planes + + logical :: compensate_normal = .true. + !! Compensate mismatch strain by adjusting the axes parallel to the interface normal vector + !! Compensate = false = strained + !! Compensate = true = relaxed (compensate for interfacial strain by extending/compressing) + + real(real32) :: bondlength_cutoff = 6._real32 + !! Maximum bond length cutoff for the bulk structures + real(real32), dimension(2) :: layer_separation_cutoff = 1._real32 + !! Minimum separation between layers + + type(tol_type) :: tolerance + !! Tolerance structure + real(real32) :: tol_sym = 1.E-6_real32 + !! Tolerance for symmetry operations + + contains + procedure, pass(this) :: get_all_structures_data + !! Get the structure data for all structures + procedure, pass(this) :: get_structure_data + !! Get the structure data for a specific structure + procedure, pass(this) :: get_all_structures_mismatch + !! Get the mismatch data for all structures + procedure, pass(this) :: get_structure_mismatch + !! Get the mismatch data for a specific structure + procedure, pass(this) :: get_all_structures_transform + !! Get the structure data for a specific structure + procedure, pass(this) :: get_structure_transform + !! Get the structure data for a specific structure + procedure, pass(this) :: get_all_structures_shift + !! Get the shifts for all structures + procedure, pass(this) :: get_structure_shift + !! Get the shifts for a specific structure + + procedure, pass(this) :: write_match_and_term_data + !! Write the match and termination data to a file + procedure, pass(this) :: write_shift_data + !! Write the shift data to a file + + procedure, pass(this) :: set_tolerance + !! Set tolerance for identifying good lattice matches + procedure, pass(this) :: set_shift_method + !! Set the shift method and associated data + procedure, pass(this) :: set_swap_method + !! Set the swap method and associated data + procedure, pass(this) :: set_match_method + !! Set the lattice match method and associated data + + procedure, pass(this) :: set_materials + !! Set the input materials for the interface generator + procedure, pass(this) :: set_surface_properties + !! Set the surface properties for the interface generator + procedure, pass(this) :: reset_is_layered_lw + !! Reset the is_layered flags for the lower bulk structure + procedure, pass(this) :: reset_is_layered_up + !! Reset the is_layered flags for the upper bulk structure + + procedure, pass(this) :: get_terminations + !! Return the terminations for structure + procedure, pass(this) :: get_interface_location + !! Get the interface location for the given structure + + procedure, pass(this) :: generate => generate_interfaces + !! Generate interfaces from two bulk structures + procedure, pass(this) :: regenerate => generate_interfaces_from_existing + !! Generate interfaces from existing bulk structures + procedure, pass(this) :: generate_perturbations => generate_shifts_and_swaps + !! Generate perturbations for the given basis + + procedure, pass(this) :: clear_structures + !! Clear the structures + end type artemis_generator_type + +contains + +!############################################################################### + function get_all_structures_data(this) result(output) + !! Get the structure data for all structures + implicit none + + ! Arguments + class(artemis_generator_type), intent(in) :: this + !! Instance of artemis generator type + + type(struc_data_type), dimension(this%num_structures) :: output + !! Structure data + + ! Local variables + integer :: i + + do i = 1, this%num_structures + output(i) = this%structure_data(i) + end do + + end function get_all_structures_data +!############################################################################### + + +!############################################################################### + function get_structure_data(this, idx) result(output) + !! Get the structure data for a specific structure + implicit none + + ! Arguments + class(artemis_generator_type), intent(in) :: this + !! Instance of artemis generator type + integer, intent(in) :: idx + !! Index of the structure + + type(struc_data_type) :: output + !! Structure data + + output = this%structure_data(idx) + + end function get_structure_data +!############################################################################### + + +!############################################################################### + function get_all_structures_mismatch(this) result(output) + !! Get the mismatch data for all structures + implicit none + + ! Arguments + class(artemis_generator_type), intent(in) :: this + !! Instance of artemis generator type + + real(real32), dimension(3,this%num_structures) :: output + !! Mismatch data + + ! Local variables + integer :: i + + do i = 1, this%num_structures + output(:,i) = this%structure_data(i)%mismatch + end do + + end function get_all_structures_mismatch +!############################################################################### + + +!############################################################################### + function get_structure_mismatch(this, idx) result(output) + !! Get the mismatch data for a specific structure + implicit none + + ! Arguments + class(artemis_generator_type), intent(in) :: this + !! Instance of artemis generator type + integer, intent(in) :: idx + !! Index of the structure + + real(real32), dimension(3) :: output + !! Mismatch data + + output = this%structure_data(idx)%mismatch + + end function get_structure_mismatch +!############################################################################### + + +!############################################################################### + function get_all_structures_transform(this) result(output) + !! Get the structure data for a specific structure + implicit none + + ! Arguments + class(artemis_generator_type), intent(in) :: this + !! Instance of artemis generator type + + integer, dimension(3,3,2,this%num_structures) :: output + !! Transformation data + + ! Local variables + integer :: i + ! Loop over all structures + + do i = 1, this%num_structures + output(:,:,1,i) = this%structure_data(i)%transform_lw + output(:,:,2,i) = this%structure_data(i)%transform_up + end do + + end function get_all_structures_transform +!############################################################################### + + +!############################################################################### + function get_structure_transform(this, idx) result(output) + !! Get the structure data for a specific structure + implicit none + + ! Arguments + class(artemis_generator_type), intent(in) :: this + !! Instance of artemis generator type + integer, intent(in) :: idx + !! Index of the structure + + integer, dimension(3,3,2) :: output + !! Transformation data + + output(:,:,1) = this%structure_data(idx)%transform_lw + output(:,:,2) = this%structure_data(idx)%transform_up + + end function get_structure_transform +!############################################################################### + + +!############################################################################### + function get_all_structures_shift(this) result(output) + !! Get the shifts for all structures + implicit none + + ! Arguments + class(artemis_generator_type), intent(in) :: this + !! Instance of artemis generator type + + real(real32), dimension(3,this%num_structures) :: output + !! Shift data + + ! Local variables + integer :: i + + do i = 1, this%num_structures + output(:,i) = this%structure_data(i)%shift + end do + + end function get_all_structures_shift +!############################################################################### + + +!############################################################################### + function get_structure_shift(this, idx) result(output) + !! Get the shifts for a specific structure + implicit none + + ! Arguments + class(artemis_generator_type), intent(in) :: this + !! Instance of artemis generator type + integer, intent(in) :: idx + !! Index of the structure + + real(real32), dimension(3) :: output + !! Shift data + + output = this%structure_data(idx)%shift + + end function get_structure_shift +!############################################################################### + + +!############################################################################### + subroutine clear_structures(this) + !! Clear the structures + implicit none + + ! Arguments + class(artemis_generator_type), intent(inout) :: this + !! Instance of artemis generator type + + if(allocated(this%structure_data)) deallocate(this%structure_data) + if(allocated(this%structures)) deallocate(this%structures) + this%num_structures = 0 + + end subroutine clear_structures +!############################################################################### + + +!############################################################################### + subroutine set_tolerance( & + this, & + tolerance, & + vector_mismatch, angle_mismatch, area_mismatch, & + max_length, max_area, max_fit, max_extension, & + angle_weight, area_weight & + ) + !! Set tolerance for the best match + implicit none + + ! Arguments + class(artemis_generator_type), intent(inout) :: this + !! Instance of artemis generator type + type(tol_type), intent(in), optional :: tolerance + !! Tolerance structure + real(real32), intent(in), optional :: vector_mismatch + !! Tolerance for the vector mismatch + real(real32), intent(in), optional :: angle_mismatch + !! Tolerance for the angle mismatch + real(real32), intent(in), optional :: area_mismatch + !! Tolerance for the area mismatch + real(real32), intent(in), optional :: max_length + !! Maximum allowed length of a lattice vector + real(real32), intent(in), optional :: max_area + !! Maximum allowed area parallel to the surface + integer, intent(in), optional :: max_fit + !! Maximum allowed number of matches for each individial ... ???? area mapped out on a plane + integer, intent(in), optional :: max_extension + !! Maximum allowed integer extension of each lattice vector + real(real32), intent(in), optional :: angle_weight + !! Importance weighting of angle mismatch + real(real32), intent(in), optional :: area_weight + !! Importance weighting of area mismatch + + if(present(tolerance))then + this%tolerance = tolerance + else + if(present(vector_mismatch)) this%tolerance%vec = vector_mismatch + if(present(angle_mismatch)) this%tolerance%ang = angle_mismatch + if(present(area_mismatch)) this%tolerance%area = area_mismatch + if(present(max_length)) this%tolerance%maxlen = max_length + if(present(max_area)) this%tolerance%maxarea = max_area + if(present(max_fit)) this%tolerance%maxfit = max_fit + if(present(max_extension)) this%tolerance%maxsize = max_extension + if(present(angle_weight)) this%tolerance%ang_weight = angle_weight + if(present(area_weight)) this%tolerance%area_weight = area_weight + end if + + !!! TOLERANCE EXPECTED IN FRACTIONS OF Å, radians, and Å^2 + + end subroutine set_tolerance +!############################################################################### + + +!############################################################################### + subroutine set_shift_method( & + this, & + method, num_shifts, shifts, & + interface_depth, separation_scale, depth_method, & + bondlength_cutoff & + ) + !! Set the shift method + implicit none + + ! Arguments + class(artemis_generator_type), intent(inout) :: this + !! Instance of artemis generator type + integer, intent(in), optional :: method + !! Shift method + integer, intent(in), optional :: num_shifts + !! Number of shifts + real(real32), dimension(..), intent(in), optional :: shifts + !! Shift values + real(real32), intent(in), optional :: interface_depth + !! Interface depth + real(real32), intent(in), optional :: separation_scale + !! Separation scale + integer, intent(in), optional :: depth_method + !! Method for determining the depth to which consider atoms from interface + real(real32), intent(in), optional :: bondlength_cutoff + !! Bond length cutoff for the bulk structures + + ! Local variables + character(len=256) :: err_msg + + if(present(method)) this%shift_method = method + if(present(num_shifts)) this%num_shifts = num_shifts + if(present(interface_depth)) this%interface_depth = interface_depth + if(present(separation_scale)) this%separation_scale = separation_scale + if(present(depth_method)) this%depth_method = depth_method + if(present(bondlength_cutoff)) this%bondlength_cutoff = bondlength_cutoff + if(present(shifts)) then + if(allocated(this%shifts)) deallocate(this%shifts) + select rank(shifts) + rank(0) + allocate(this%shifts(1,3)) + this%shifts(1,this%axis) = shifts + rank(1) + allocate(this%shifts(1,3)) + select case(size(shifts,dim=1)) + case(1) + this%shifts(1,this%axis) = shifts(1) + case(3) + this%shifts(1,:) = shifts + case default + ! check if length of shifts is divisible by 3 + if(mod(size(shifts,dim=1),3).eq.0) then + allocate(this%shifts(size(shifts,dim=1)/3,3)) + this%shifts = reshape(shifts, [ size(shifts,dim=1)/3,3 ]) + else + write(err_msg,'(A,I0,A)') & + "The shifts vector has ", size(shifts, dim=1), & + " components. It should have 1 or 3." + call stop_program(trim(err_msg)) + return + end if + end select + rank(2) + select case(size(shifts,dim=2)) + case(1) + allocate(this%shifts(size(shifts,1),3)) + this%shifts(:,3) = shifts(:,1) + case(3) + allocate(this%shifts(size(shifts,1),3)) + this%shifts = shifts + case default + write(err_msg,'(A,I0,A)') & + "The shifts argument was improperly defined." + call stop_program(trim(err_msg)) + return + end select + rank default + write(err_msg,'(A,I0,A)') & + "The shifts vector has ", size(shifts, dim=1), & + " components. It should have 1, 2, or 3." + call stop_program(trim(err_msg)) + return + end select + else + if(allocated(this%shifts)) deallocate(this%shifts) + allocate(this%shifts(1,3), source = -1._real32) + end if + + end subroutine set_shift_method +!############################################################################### + + +!############################################################################### + subroutine set_swap_method( & + this, method, num_swaps, swap_density, swap_depth, swap_sigma, & + require_mirror_swaps & + ) + !! Set the swap method + implicit none + + ! Arguments + class(artemis_generator_type), intent(inout) :: this + !! Instance of artemis generator type + integer, intent(in), optional :: method + !! Swap method + integer, intent(in), optional :: num_swaps + !! Number of swaps + real(real32), intent(in), optional :: swap_density + !! Swap density + real(real32), intent(in), optional :: swap_depth + !! Swap depth + real(real32), intent(in), optional :: swap_sigma + !! Swap sigma + logical, intent(in), optional :: require_mirror_swaps + !! Require mirror swaps + + if(present(method)) this%swap_method = method + if(present(num_swaps)) this%num_swaps = num_swaps + if(present(swap_density)) this%swap_density = swap_density + if(present(swap_depth)) this%swap_depth = swap_depth + if(present(swap_sigma)) this%swap_sigma = swap_sigma + if(present(require_mirror_swaps)) & + this%require_mirror_swaps = require_mirror_swaps + + end subroutine set_swap_method +!############################################################################### + + +!############################################################################### + subroutine set_match_method( & + this, method, max_num_matches, max_num_terms, max_num_planes, & + compensate_normal & + ) + !! Set the lattice match method + implicit none + + ! Arguments + class(artemis_generator_type), intent(inout) :: this + !! Instance of artemis generator type + integer, intent(in), optional :: method + !! Match method + integer, intent(in), optional :: max_num_matches + !! Maximum number of matches + integer, intent(in), optional :: max_num_terms + !! Maximum number of terminations + integer, intent(in), optional :: max_num_planes + !! Maximum number of planes + logical, intent(in), optional :: compensate_normal + !! Compensate mismatch strain by adjusting the axes parallel to the interface normal vector + + if(present(method)) this%match_method = method + if(present(max_num_matches)) this%max_num_matches = max_num_matches + if(present(max_num_terms)) this%max_num_terms = max_num_terms + if(present(max_num_planes)) this%max_num_planes = max_num_planes + if(present(compensate_normal)) this%compensate_normal = compensate_normal + + end subroutine set_match_method +!############################################################################### + + +!############################################################################### + subroutine set_materials( & + this, structure_lw, structure_up, & + elastic_lw, elastic_up, & + use_pricel_lw, use_pricel_up & + ) + !! Set the materials for the interface generator + implicit none + + ! Arguments + class(artemis_generator_type), intent(inout) :: this + !! Instance of artemis generator type + type(basis_type), intent(in), optional :: structure_lw + !! Lower bulk structure + type(basis_type), intent(in), optional :: structure_up + !! Upper bulk structure + real(real32), dimension(:,:), intent(in), optional :: elastic_lw + !! Elastic constants for the lower bulk structure + real(real32), dimension(:,:), intent(in), optional :: elastic_up + !! Elastic constants for the upper bulk structure + logical, intent(in), optional :: use_pricel_lw + !! Use primitive cell for lower bulk structure + logical, intent(in), optional :: use_pricel_up + + ! Local variables + character(len=256) :: err_msg + !! Error message + + + if(present(structure_lw))then + if(structure_lw%natom.gt.0) call this%structure_lw%copy(structure_lw, length=4) + end if + if(present(structure_up))then + if(structure_up%natom.gt.0) call this%structure_up%copy(structure_up, length=4) + end if + + !--------------------------------------------------------------------------- + ! Handle the elastic constants + !--------------------------------------------------------------------------- + if(present(elastic_lw))then + if(allocated(this%elastic_tensor_lw)) deallocate(this%elastic_tensor_lw) + select case(size(elastic_lw,dim=1)) + case(1) + allocate(this%elastic_tensor_lw(1,1)) + this%elastic_tensor_lw(1,1) = elastic_lw(1,1) + case(6) + allocate(this%elastic_tensor_lw(6,6)) + this%elastic_tensor_lw(:,:) = elastic_lw + case default + write(err_msg,'(A)') & + "The elastic tensor for the lower bulk structure has incorrect & + &shape. It should have shape (1,1) or (6,6)." + call stop_program(trim(err_msg)) + return + end select + end if + if(present(elastic_up))then + if(allocated(this%elastic_tensor_up)) deallocate(this%elastic_tensor_up) + select case(size(elastic_up,dim=1)) + case(1) + allocate(this%elastic_tensor_up(1,1)) + this%elastic_tensor_up(1,1) = elastic_up(1,1) + case(6) + allocate(this%elastic_tensor_up(6,6)) + this%elastic_tensor_up(:,:) = elastic_up + case default + write(err_msg,'(A)') & + "The elastic tensor for the upper bulk structure has incorrect & + &shape. It should have shape (1,1) or (6,6)." + call stop_program(trim(err_msg)) + return + end select + end if + + if(present(use_pricel_lw)) this%use_pricel_lw = use_pricel_lw + if(present(use_pricel_up)) this%use_pricel_up = use_pricel_up + + + end subroutine set_materials +!############################################################################### + + +!############################################################################### + subroutine set_surface_properties( & + this, & + miller_lw, miller_up, & + is_layered_lw, is_layered_up, & + require_stoichiometry_lw, require_stoichiometry_up, & + layer_separation_cutoff_lw, layer_separation_cutoff_up, & + layer_separation_cutoff, & + vacuum_gap & + ) + !! Set the surface properties for the interface generator + implicit none + + ! Arguments + class(artemis_generator_type), intent(inout) :: this + !! Instance of artemis generator type + integer, dimension(3), intent(in), optional :: miller_lw + !! Miller indices for the lower bulk structure + integer, dimension(3), intent(in), optional :: miller_up + !! Miller indices for the upper bulk structure + + logical, intent(in), optional :: is_layered_lw + !! Boolean whether the lower bulk structure is layered + logical, intent(in), optional :: is_layered_up + !! Boolean whether the upper bulk structure is layered + + logical, intent(in), optional :: require_stoichiometry_lw + !! Boolean whether to require stoichiometry for the lower bulk structure + logical, intent(in), optional :: require_stoichiometry_up + !! Boolean whether to require stoichiometry for the upper bulk structure + + real(real32), intent(in), optional :: layer_separation_cutoff_lw + !! Layer separation cutoff for the lower bulk structure + real(real32), intent(in), optional :: layer_separation_cutoff_up + !! Layer separation cutoff for the upper bulk structure + real(real32), dimension(..), intent(in), optional :: layer_separation_cutoff + !! Layer separation cutoff + + real(real32), intent(in), optional :: vacuum_gap + !! Vacuum gap for termination generator + + ! Local variables + character(len=256) :: err_msg + !! Error message + + + if(present(miller_lw)) this%miller_lw = miller_lw + if(present(miller_up)) this%miller_up = miller_up + + if(present(is_layered_lw))then + this%is_layered_lw = is_layered_lw + this%ludef_is_layered_lw = .true. + end if + if(present(is_layered_up))then + this%is_layered_up = is_layered_up + this%ludef_is_layered_up = .true. + end if + + if(present(require_stoichiometry_lw)) & + this%require_stoichiometry_lw = require_stoichiometry_lw + if(present(require_stoichiometry_up)) & + this%require_stoichiometry_up = require_stoichiometry_up + + if(present(vacuum_gap)) this%vacuum_gap = vacuum_gap + + if(present(layer_separation_cutoff_lw)) & + this%layer_separation_cutoff(1) = layer_separation_cutoff_lw + if(present(layer_separation_cutoff_up)) & + this%layer_separation_cutoff(2) = layer_separation_cutoff_up + + if( ( present(layer_separation_cutoff_lw) .or. & + present(layer_separation_cutoff_up) ) .and. & + present(layer_separation_cutoff) ) then + write(err_msg,'(A)') & + "The layer separation cutoff is defined in two ways. Please use only one." + call stop_program(trim(err_msg)) + return + elseif(present(layer_separation_cutoff))then + select rank(layer_separation_cutoff) + rank(0) + this%layer_separation_cutoff(:) = layer_separation_cutoff + rank(1) + select case(size(layer_separation_cutoff,dim=1)) + case(1) + this%layer_separation_cutoff = layer_separation_cutoff(1) + case(2) + this%layer_separation_cutoff = layer_separation_cutoff + case default + write(err_msg,'(A,I0,A)') & + "The layer separation cutoff vector has ", & + size(layer_separation_cutoff,dim=1), & + " components. It should have 1 or 2." + call stop_program(trim(err_msg)) + return + end select + rank default + write(err_msg,'(A,I0,A)') & + "The layer separation cutoff only accepts rank 0 or 1." + call stop_program(trim(err_msg)) + return + end select + end if + if(any(this%layer_separation_cutoff.lt.1.E-2_real32))then + write(err_msg,'(A,I0,A)') & + "A layer separation this small is not realistic: ", & + this%layer_separation_cutoff + call stop_program(trim(err_msg)) + return + end if + + end subroutine set_surface_properties +!############################################################################### + + +!############################################################################### + subroutine reset_is_layered_lw(this) + !! Reset the is_layered flags + implicit none + + ! Arguments + class(artemis_generator_type), intent(inout) :: this + !! Instance of artemis generator type + + this%is_layered_lw = .false. + this%ludef_is_layered_lw = .false. + + end subroutine reset_is_layered_lw +!############################################################################### + + +!############################################################################### + subroutine reset_is_layered_up(this) + !! Reset the is_layered flags + implicit none + + ! Arguments + class(artemis_generator_type), intent(inout) :: this + !! Instance of artemis generator type + + this%is_layered_up = .false. + this%ludef_is_layered_up = .false. + + end subroutine reset_is_layered_up +!############################################################################### + + +!############################################################################### + function get_terminations( & + this, identifier, miller, surface, num_layers, thickness, & + orthogonalise, normalise, break_on_fail, & + print_termination_info, verbose, exit_code & + ) result(output) + !! Generate and prints terminations parallel to the supplied miller plane + implicit none + + ! Arguments + class(artemis_generator_type), intent(inout) :: this + !! Instance of artemis generator type + integer, intent(in) :: identifier + !! Identifier for the material (1=lower, 2=upper) + integer, dimension(3), intent(in), optional :: miller + !! Miller plane + integer, dimension(:), intent(in), optional :: surface + !! Surface termination indices + integer, intent(in), optional :: num_layers + !! Number of layers in the slab + real(real32), intent(in), optional :: thickness + !! Thickness of the slab (in Å) + logical, intent(in), optional :: orthogonalise + !! Boolean whether to orthogonalise the lattice + logical, intent(in), optional :: normalise + !! Boolean whether to normalise the lattice and basis + logical, intent(in), optional :: break_on_fail + !! Boolean whether to break on failure + logical, intent(in), optional :: print_termination_info + !! Boolean whether to print termination information + integer, intent(in), optional :: verbose + !! Boolean whether to print verbose output + integer, intent(out), optional :: exit_code + !! Exit code for the program + + type(basis_type), dimension(:), allocatable :: output + !! Output structures + + ! Local variables + integer :: itmp1, iterm, term_start, term_end, term_step, i + !! Termination loop variables + integer :: num_cells, ntrans + !! Number of cells in the slab + integer :: num_structures + !! Number of structures to be generated + integer, dimension(2) :: surface_ + !! Surface termination indices + integer, dimension(3) :: miller_ + !! Miller plane + integer :: num_layers_ + !! Number of layers in the slab + real(real32) :: height, thickness_ + !! Height of the slab + logical :: lcycle + !! Boolean whether to cycle through the slab + type(basis_type) :: structure, structure_compare + !! Temporary basis structures + type(confine_type) :: confine + !! Confine structure along the specified axis + type(term_arr_type) :: term + !! List of terminations + real(real32), dimension(3,3) :: tfmat + !! Transformation matrix + logical :: orthogonalise_ + !! Boolean whether to orthogonalise the lattice + logical :: normalise_ + !! Boolean whether to normalise the lattice + logical :: break_on_fail_ + !! Boolean whether to break on failure + logical :: print_termination_info_ + !! Boolean whether to print termination information + + + real(real32) :: layer_sep + character(len=2) :: prefix + character(len=256) :: warn_msg, err_msg + integer :: exit_code_ + !! Exit code for the program + integer :: verbose_ + !! Verbosity level + + integer, allocatable, dimension(:,:,:) :: bas_map,t1bas_map + real(real32), allocatable, dimension(:,:) :: trans + + + !--------------------------------------------------------------------------- + ! Initialise variables + !--------------------------------------------------------------------------- + exit_code_ = 0 + verbose_ = 0 + print_termination_info_ = .true. + if(present(verbose)) verbose_ = verbose + if(present(print_termination_info)) & + print_termination_info_ = print_termination_info + + + !--------------------------------------------------------------------------- + ! Handle identifier + !--------------------------------------------------------------------------- + select case(identifier) + case(1) + call structure%copy(this%structure_lw, length=4) + call structure_compare%copy(this%structure_lw, length=4) + if(this%use_pricel_lw)then + if(verbose_.gt.0) write(*,'(1X,"Using primitive cell for material")') + call get_primitive_cell(structure, tol_sym=this%tol_sym) + end if + miller_ = this%miller_lw + prefix = "lw" + layer_sep = this%layer_separation_cutoff(1) + case(2) + call structure%copy(this%structure_up, length=4) + call structure_compare%copy(this%structure_up, length=4) + if(this%use_pricel_up)then + if(verbose_.gt.0) write(*,'(1X,"Using primitive cell for material")') + call get_primitive_cell(structure, tol_sym=this%tol_sym) + end if + miller_ = this%miller_up + prefix = "up" + layer_sep = this%layer_separation_cutoff(2) + case default + write(err_msg,'(A,I0,A)') & + "The identifier for the material is not valid: ", identifier + call stop_program(trim(err_msg)) + return + end select + ! check if the structures have anything (i.e. atoms) in them + if(structure%natom.eq.0)then + write(err_msg,'(A,I0,A)') & + "The structure has ", structure%natom, & + " atoms. It should have at least 1." + call stop_program(trim(err_msg)) + return + end if + + + ! set thickness if provided by user + thickness_ = -1._real32 + num_layers_ = 0 + if(present(num_layers)) num_layers_ = num_layers + if(present(thickness)) thickness_ = thickness + if(num_layers_.eq.0.and.abs(thickness_+1._real32).lt.1.E-6_real32)then + thickness_ = 10._real32 + elseif(num_layers_.le.0.and.thickness_.le.0._real32)then + write(err_msg,'(A,I0,A)') & + "The number of layers for the material is ", & + num_layers_, " and the thickness is ", thickness_, & + " One of these must be greater than 0." + call stop_program(trim(err_msg)) + exit_code_ = 1 + return + end if + + + !--------------------------------------------------------------------------- + ! Handle the miller plane + !--------------------------------------------------------------------------- + if(present(miller)) miller_ = miller + if(all(miller_.eq.0))then + write(err_msg,'(A,I0,A)') & + "The miller plane is not valid: ", identifier + call stop_program(trim(err_msg)) + exit_code_ = 1 + return + end if + + + orthogonalise_ = .true. + if(present(orthogonalise)) orthogonalise_ = orthogonalise + break_on_fail_ = .false. + if(present(break_on_fail)) break_on_fail_ = break_on_fail + normalise_ = .true. + if(present(normalise)) normalise_ = normalise + surface_ = 0 + if(present(surface))then + select case(size(surface,dim=1)) + case(1) + surface_(:) = surface(1) + case(2) + surface_ = surface + case default + write(err_msg,'(A,I0,A)') & + "The surface termination indices have ", size(surface,dim=1), & + " components. It should have 1 or 2." + exit_code_ = 1 + call stop_program( & + trim(err_msg), & + exit_code=exit_code_, & + block_stop = present(exit_code) & + ) + return + end select + end if + + !! copy lattice and basis for manipulating + allocate(bas_map(structure%nspec,maxval(structure%spec(:)%num,dim=1),2)) + bas_map = -1 + + + if(verbose_.gt.0) write(*,'(1X,"Using supplied plane...")') + tfmat = planecutter(structure%lat,real(miller_,real32)) + call transformer(structure,tfmat,bas_map) + + + !--------------------------------------------------------------------------- + ! Finds smallest thickness of the slab and increases to ... + ! ... user-defined thickness + !--------------------------------------------------------------------------- + confine%l = .false. + confine%axis = this%axis + confine%laxis = .false. + confine%laxis(this%axis) = .true. + if(allocated(trans)) deallocate(trans) + allocate(trans(minval(structure%spec(:)%num+2),3)) + call gldfnd(confine, structure, structure, trans, ntrans, this%tol_sym) + tfmat(:,:) = 0._real32 + tfmat(1,1) = 1._real32 + tfmat(2,2) = 1._real32 + if(ntrans.eq.0)then + tfmat(3,3) = 1._real32 + else + itmp1=minloc(abs(trans(:ntrans,this%axis)),dim=1,& + mask=abs(trans(:ntrans,this%axis)).gt.1.D-3/modu(structure%lat(this%axis,:))) + tfmat(3,:) = trans(itmp1,:) + end if + if(all(abs(tfmat(3,:)).lt.1.E-5_real32)) tfmat(3,3) = 1._real32 + call transformer(structure,tfmat,bas_map) + if(.not.compare_stoichiometry(structure,structure_compare))then + write(err_msg,'(A,I0,A)') & + "The transformed structure stoichiometry does not match the & + &original structure." + exit_code_ = 1 + call stop_program( & + trim(err_msg), & + exit_code=exit_code_, & + block_stop = present(exit_code) & + ) + return + end if + + + ! get the terminations + term = get_termination_info( & + structure, this%axis, & + verbose = merge(1,verbose_,print_termination_info_), & + tol_sym = this%tol_sym, & + layer_sep = layer_sep, & + exit_code = exit_code_ & + ) + if(exit_code_.ne.0)then + write(err_msg,'(A,I0,A)') & + "The termination generator failed with exit code ", exit_code_ + if(break_on_fail_)then + call stop_program(trim(err_msg)) + return + end if + end if + if(term%nterm .eq. 0)then + write(warn_msg, '(A,I0,1X,I0,1X,I0,A)') & + "No terminations found for Miller plane (",miller_,")" + call print_warning(trim(warn_msg)) + return + end if + + ! determine tolerance for layer separations (termination tolerance) + ! ... this is different from layer_sep + call set_layer_tol(term) + + ! determine required extension and perform that + call build_slab_supercell(structure, bas_map, term, surface_,& + height, num_layers_, thickness_, num_cells,& + term_start, term_end, term_step & + ) + + + !--------------------------------------------------------------------------- + ! loop over terminations and write them + !--------------------------------------------------------------------------- + num_structures = ( term_end - term_start ) / term_step + 1 + allocate(output(num_structures)) + do iterm = term_start, term_end, term_step + i = ( iterm - term_start ) / term_step + 1 + call output(i)%copy(structure, length=4) + if(allocated(t1bas_map)) deallocate(t1bas_map) + allocate(t1bas_map,source=bas_map) + call cut_slab_to_height(output(i),bas_map,term,[iterm,surface_(2)],& + thickness_, num_cells, num_layers_, height,& + prefix, lcycle, orthogonalise_, this%vacuum_gap & + ) + ! Normalise lattice + !------------------------------------------------------------------------ + if(normalise_)then + call reducer(output(i), verbose = verbose_) + output(i)%lat = MATNORM(output(i)%lat) + end if + end do + + end function get_terminations +!############################################################################### + + +!############################################################################### + function get_interface_location( & + this, structure, axis, return_fractional, verbose, exit_code & + ) result(output) + !! Get the interface location for the given structure + implicit none + + ! Arguments + class(artemis_generator_type), intent(inout) :: this + !! Instance of artemis generator type + type(basis_type), intent(in) :: structure + !! Atomic structure data + integer, intent(in), optional :: axis + !! Axis for the interface + logical, intent(in), optional :: return_fractional + !! Return the interface location in fractional coordinates + integer, intent(in), optional :: verbose + !! Verbosity level + integer, intent(out), optional :: exit_code + !! Exit code for the program + + type(intf_info_type) :: output + !! Output interface location + + ! Local variables + integer :: axis_ + !! Axis for the interface + logical :: return_fractional_ + !! Return fractional coordinates + integer :: exit_code_ + !! Exit code for the program + + axis_ = 0 + exit_code_ = 0 + return_fractional_ = .false. + if(present(axis)) axis_ = axis + if(present(return_fractional)) return_fractional_ = return_fractional + + output = get_interface(structure, axis_) + + if(return_fractional_)then + output%loc = output%loc / modu(structure%lat(output%axis,:)) + end if + + if(present(exit_code)) exit_code = exit_code_ + + end function get_interface_location +!############################################################################### + + +!############################################################################### + subroutine generate_interfaces_from_existing( & + this, structure, interface_location, & + print_shift_info, seed, verbose, exit_code & + ) + !! Generate swaps and shifts for an existing interface + implicit none + + ! Arguments + class(artemis_generator_type), intent(inout) :: this + !! Instance of artemis generator type + type(basis_type), intent(in) :: structure + !! Atomic structure data + real(real32), dimension(2), intent(in), optional :: interface_location + !! Interface location + logical, intent(in), optional :: print_shift_info + !! Print shift information + integer, intent(in), optional :: seed + !! Random seed for generating random numbers + integer, intent(in), optional :: verbose + !! Verbosity level + integer, intent(out), optional :: exit_code + !! Exit code for the program + + ! Local variables + integer :: is, ia, js, ja + !! Loop variables + real(real32) :: rtmp1,min_bond,min_bond1,min_bond2 + !! Minimum bond length + type(intf_info_type) :: intf + !! Interface information + type(struc_data_type) :: struc_data + !! Structure data + real(real32), dimension(3) :: vtmp1 + !! Temporary vector + logical :: print_shift_info_ + !! Print shift information + integer :: num_seed + !! Number of seeds for the random number generator. + integer, dimension(:), allocatable :: seed_arr + !! Array of seeds for the random number generator. + + type(bulk_DON_type), dimension(2) :: bulk_DON + !! Distribution functions for the lower and upper bulk structures + + integer :: verbose_ + !! Verbosity level + integer :: exit_code_ + !! Exit code for the program + + + !--------------------------------------------------------------------------- + ! Initialise variables + !--------------------------------------------------------------------------- + exit_code_ = 0 + verbose_ = 0 + if(present(verbose)) verbose_ = verbose + + + !--------------------------------------------------------------------------- + ! Set the random seed + !--------------------------------------------------------------------------- + if(present(seed))then + call random_seed(size=num_seed) + allocate(seed_arr(num_seed)) + seed_arr = seed + call random_seed(put=seed_arr) + else + call random_seed(size=num_seed) + allocate(seed_arr(num_seed)) + call random_seed(get=seed_arr) + end if + + print_shift_info_ = .false. + if(present(print_shift_info)) print_shift_info_ = print_shift_info + + if(.not.allocated(this%structures)) allocate(this%structures(0)) + + + min_bond1 = huge(0._real32) + min_bond2 = huge(0._real32) + if(present(interface_location))then + intf%axis = this%axis + intf%loc = interface_location + else + intf = get_interface(structure,this%axis) + intf%loc = intf%loc/modu(structure%lat(intf%axis,:)) + if(verbose_.gt.0) write(*,*) "interface axis:",intf%axis + if(verbose_.gt.0) write(*,*) "interface loc:",intf%loc + end if + specloop1: do is = 1, structure%nspec + atomloop1: do ia = 1, structure%spec(is)%num + + specloop2: do js = 1, structure%nspec + atomloop2: do ja = 1, structure%spec(js)%num + if(is.eq.js.and.ia.eq.ja) cycle atomloop2 + if( & + ( structure%spec(is)%atom(ia,intf%axis).gt.intf%loc(1).and.& + structure%spec(is)%atom(ia,intf%axis).lt.intf%loc(2) ).and.& + ( structure%spec(js)%atom(ja,intf%axis).gt.intf%loc(1).and.& + structure%spec(js)%atom(ja,intf%axis).lt.intf%loc(2) ) )then + vtmp1 = (structure%spec(is)%atom(ia,:3)-structure%spec(js)%atom(ja,:3)) + vtmp1 = matmul(vtmp1,structure%lat) + rtmp1 = modu(vtmp1) + if(rtmp1.lt.min_bond1) min_bond1 = rtmp1 + elseif( & + ( structure%spec(is)%atom(ia,intf%axis).lt.intf%loc(1).or.& + structure%spec(is)%atom(ia,intf%axis).gt.intf%loc(2) ).and.& + ( structure%spec(js)%atom(ja,intf%axis).lt.intf%loc(1).or.& + structure%spec(js)%atom(ja,intf%axis).gt.intf%loc(2) ) )then + vtmp1 = (structure%spec(is)%atom(ia,:3)-structure%spec(js)%atom(ja,:3)) + vtmp1 = matmul(vtmp1,structure%lat) + rtmp1 = modu(vtmp1) + if(rtmp1.lt.min_bond2) min_bond2 = rtmp1 + end if + + end do atomloop2 + end do specloop2 + + end do atomloop1 + end do specloop1 + + min_bond = ( min_bond1 + min_bond2 ) / 2._real32 + if(verbose_.gt.0) write(*,'(1X,"Avg min bulk bond: ",F0.3," Å")') min_bond + if(verbose_.gt.0) write(*,'(1X,"Trans-interfacial scaling factor:",F0.3)') this%separation_scale + this%axis = intf%axis + call this%generate_perturbations( & + structure, intf%loc, & + min_bond, bulk_DON, & + struc_data, & + print_shift_info_, seed_arr, verbose_, exit_code_ & + ) + + if(present(exit_code)) exit_code = exit_code_ + + end subroutine generate_interfaces_from_existing +!############################################################################### + + +!############################################################################### + subroutine generate_interfaces( & + this, & + surface_lw, surface_up, & + thickness_lw, thickness_up, & + num_layers_lw, num_layers_up, & + reduce_matches, & + print_lattice_match_info, print_termination_info, print_shift_info, & + break_on_fail, & + icheck_term_pair, interface_idx, & + generate_structures, & + seed, verbose, exit_code & + ) + !! Generate interfaces from two bulk structures + implicit none + + ! Arguments + class(artemis_generator_type), intent(inout) :: this + !! Instance of artemis generator type + integer, intent(in), dimension(:), optional :: surface_lw + !! Surface indices for the lower bulk structure + integer, intent(in), dimension(:), optional :: surface_up + !! Surface indices for the upper bulk structure + real(real32), intent(in), optional :: thickness_lw + !! Thickness of the lower slab + real(real32), intent(in), optional :: thickness_up + !! Thickness of the upper slab + integer, intent(in), optional :: num_layers_lw + !! Number of layers in the lower slab + integer, intent(in), optional :: num_layers_up + !! Number of layers in the upper slab + logical, intent(in), optional :: reduce_matches + !! Reduce lattice matches to their smallest cell (UNSTABLE) + + logical, intent(in), optional :: break_on_fail + !! Break on failure + logical, intent(in), optional :: print_lattice_match_info + !! Print lattice match information + logical, intent(in), optional :: print_termination_info + !! Print termination information + logical, intent(in), optional :: print_shift_info + !! Print shift information + integer, intent(in), optional :: icheck_term_pair + !! Index of the lattice match to check + integer, intent(in), optional :: interface_idx + !! Index of the interface to output + logical, intent(in), optional :: generate_structures + !! Boolean whether to generate structures or just print information + integer, intent(in), optional :: seed + !! Random seed for generating random numbers + integer, intent(in), optional :: verbose + !! Verbosity level + integer, intent(out), optional :: exit_code + !! Exit code for the function + + ! Local variables + real(real32) :: avg_min_bond + !! Average minimum bond length + + type(basis_type) :: structure_lw, structure_up, supercell_lw, supercell_up + !! Copy of the basis structures + type(basis_type) :: slab_lw, slab_up + !! Slab structures + type(basis_type) :: intf_basis + !! Interface structure + character(len=256) :: err_msg + !! Error message + + integer :: j, is, ia + !! Loop indices + integer :: unit + !! Unit number for file I/O + integer :: ifit, intf_start, intf_end + !! Interface loop indices + integer :: iterm_lw, term_lw_start_idx, term_lw_end_idx, term_lw_step + !! Lower bulk termination loop indices + integer :: iterm_up, term_up_start_idx, term_up_end_idx, term_up_step + !! Upper bulk termination loop indices + + ! slab thickness variables + integer :: num_cells_lw, num_cells_up + !! Number of cells in the slab + real(real32) :: height_lw, height_up + !! Height of the slab + real(real32) :: thickness_lw_, thickness_up_ + !! Thickness of the slab + integer :: num_layers_lw_, num_layers_up_ + !! Number of layers in the slab + + integer, dimension(3) :: miller_lw, miller_up + !! Miller indices for the lower and upper bulk structures + integer, dimension(2) :: surface_lw_, surface_up_ + !! Surface indices for the lower and upper bulk structures + logical :: ludef_surface_lw, ludef_surface_up + !! Boolean whether surfaces are defined + logical :: lcycle + !! Boolean whether to skip the cycle + + logical :: break_on_fail_ + !! Boolean whether to break on failure + logical :: print_lattice_match_info_, print_termination_info_, & + print_shift_info_ + !! Boolean whether to print lattice match, termination, and shift info + integer :: num_seed + !! Number of seeds for the random number generator. + integer, dimension(:), allocatable :: seed_arr + !! Array of seeds for the random number generator. + integer :: icheck_term_pair_ + !! Index of the lattice match to check + integer :: interface_idx_ + !! Index of the interface to output + logical :: generate_structures_ + !! Boolean whether to generate structures or just print information + + + type(struc_data_type) :: struc_data + !! Structure data (i.e. mismatch, terminations, etc) + character(len=256) :: filename + !! Filename for error output data + real(real32) :: rtmp1, bondlength + !! Temporary variables + + integer :: ntrans, iunique, itmp1, num_structures_old + integer :: layered_axis_lw, layered_axis_up + type(confine_type) :: confine + type(latmatch_type) :: SAV + type(term_arr_type) :: lw_term, up_term + integer, dimension(3) :: ivtmp1 + real(real32), dimension(2) :: intf_loc + real(real32), dimension(3) :: init_offset + logical :: reduce_matches_ + !! Boolean whether to reduce lattice matches to their smallest cell + real(real32), dimension(3,3) :: tfmat + !! Transformation matrix + type(bulk_DON_type), dimension(2) :: bulk_DON + !! Distribution functions for the lower and upper bulk structures + integer, allocatable, dimension(:,:,:) :: lw_map, t1lw_map, t2lw_map + integer, allocatable, dimension(:,:,:) :: up_map, t1up_map, t2up_map + real(real32), allocatable, dimension(:,:) :: trans + + integer :: exit_code_ + !! Exit code for the function + integer :: verbose_ + !! Verbosity level + + + !--------------------------------------------------------------------------- + ! Initialise variables + !--------------------------------------------------------------------------- + exit_code_ = 0 + verbose_ = 0 + reduce_matches_ = .false. + if(present(verbose)) verbose_ = verbose + if(present(reduce_matches)) reduce_matches_ = reduce_matches + + icheck_term_pair_ = -1; interface_idx_ = -1 + if(present(icheck_term_pair)) icheck_term_pair_ = icheck_term_pair + if(present(interface_idx)) interface_idx_ = interface_idx + + break_on_fail_ = .false. + if(present(break_on_fail)) break_on_fail_ = break_on_fail + + generate_structures_ = .true. + if(present(generate_structures)) generate_structures_ = generate_structures + + print_lattice_match_info_ = .false. + print_termination_info_ = .false. + print_shift_info_ = .false. + if(present(print_lattice_match_info)) & + print_lattice_match_info_ = print_lattice_match_info + if(present(print_termination_info)) & + print_termination_info_ = print_termination_info + if(present(print_shift_info)) print_shift_info_ = print_shift_info + + init_offset = [0._real32,0._real32,2._real32] + if(.not.allocated(this%shifts)) call this%set_shift_method() + + + !--------------------------------------------------------------------------- + ! Set the random seed + !--------------------------------------------------------------------------- + if(present(seed))then + call random_seed(size=num_seed) + allocate(seed_arr(num_seed)) + seed_arr = seed + call random_seed(put=seed_arr) + else + call random_seed(size=num_seed) + allocate(seed_arr(num_seed)) + call random_seed(get=seed_arr) + end if + + + !--------------------------------------------------------------------------- + ! Check if the structures are valid + !--------------------------------------------------------------------------- + ! check if the structures have anything (i.e. atoms) in them + if(this%structure_lw%natom.eq.0)then + write(err_msg,'(A,I0,A)') & + "The lower structure has ", this%structure_lw%natom, & + " atoms. It should have at least 1." + exit_code_ = 1 + call stop_program( & + trim(err_msg), & + exit_code=exit_code_, & + block_stop = present(exit_code) & + ) + return + end if + if(this%structure_up%natom.eq.0)then + write(err_msg,'(A,I0,A)') & + "The upper structure has ", this%structure_lw%natom, & + " atoms. It should have at least 1." + exit_code_ = 1 + call stop_program( & + trim(err_msg), & + exit_code=exit_code_, & + block_stop = present(exit_code) & + ) + return + end if + call structure_lw%copy(this%structure_lw, length=4) + call structure_up%copy(this%structure_up, length=4) + if(.not.allocated(this%structures)) allocate(this%structures(0)) + if(.not.allocated(this%structure_data)) allocate(this%structure_data(0)) + + + !--------------------------------------------------------------------------- + ! Retrieve the primitive cells if necessary + !--------------------------------------------------------------------------- + if(this%use_pricel_lw)then + if(verbose_.gt.0) write(*,'(1X,"Using primitive cell for lower material")') + call get_primitive_cell(structure_lw, tol_sym=this%tol_sym) + else + if(verbose_.gt.0) write(*,'(1X,"Using supplied cell for lower material")') + call primitive_lat(structure_lw) + end if + if(this%use_pricel_up)then + if(verbose_.gt.0) write(*,'(1X,"Using primitive cell for upper material")') + call get_primitive_cell(structure_up, tol_sym=this%tol_sym) + else + if(verbose_.gt.0) write(*,'(1X,"Using supplied cell for upper material")') + call primitive_lat(structure_up) + end if + + + !--------------------------------------------------------------------------- + ! Handle surface properties + !--------------------------------------------------------------------------- + miller_lw = this%miller_lw + miller_up = this%miller_up + surface_lw_ = 0 + surface_up_ = 0 + if(present(surface_lw))then + select case(size(surface_lw, dim=1)) + case(1) + surface_lw_ = surface_lw(1) + case(2) + surface_lw_ = surface_lw + case default + write(err_msg,'(A,I0,A)') & + "The surface vector for the lower material has ", & + size(surface_lw, dim=1), " components. It should have 1 or 2." + call stop_program(trim(err_msg)) + return + end select + end if + if(present(surface_up))then + select case(size(surface_up, dim=1)) + case(1) + surface_up_ = surface_up(1) + case(2) + surface_up_ = surface_up + case default + write(err_msg,'(A,I0,A)') & + "The surface vector for the upper material has ", & + size(surface_up, dim=1), " components. It should have 1 or 2." + call stop_program(trim(err_msg)) + return + end select + end if + + ludef_surface_lw = .false. + ludef_surface_up = .false. + if(all(surface_lw_.gt.0)) ludef_surface_lw = .true. + if(all(surface_up_.gt.0)) ludef_surface_up = .true. + + thickness_lw_ = -1._real32 + thickness_up_ = -1._real32 + num_layers_lw_ = 0 + num_layers_up_ = 0 + if(present(num_layers_lw)) num_layers_lw_ = num_layers_lw + if(present(num_layers_up)) num_layers_up_ = num_layers_up + if(present(thickness_lw)) thickness_lw_ = thickness_lw + if(present(thickness_up)) thickness_up_ = thickness_up + if(num_layers_lw_.eq.0.and.abs(thickness_lw_+1._real32).lt.1.E-6_real32)then + thickness_lw_ = 10._real32 + elseif(num_layers_lw_.le.0.and.thickness_lw_.le.0._real32)then + write(err_msg,'(A,I0,A)') & + "The number of layers for the lower material is ", & + num_layers_lw_, " and the thickness is ", thickness_lw_, & + " One of these must be greater than 0." + call stop_program(trim(err_msg)) + return + end if + if(num_layers_up_.eq.0.and.abs(thickness_up_+1._real32).lt.1.E-6_real32)then + thickness_up_ = 10._real32 + elseif(num_layers_up_.le.0.and.thickness_up_.le.0._real32)then + write(err_msg,'(A,I0,A)') & + "The number of layers for the upper material is ", & + num_layers_up_, " and the thickness is ", thickness_up_, & + " One of these must be greater than 0." + call stop_program(trim(err_msg)) + return + end if + + + !--------------------------------------------------------------------------- + ! Get the average bond length + !--------------------------------------------------------------------------- + avg_min_bond = & + ( & + get_min_bulk_bond(structure_lw) + & + get_min_bulk_bond(structure_up) & + ) / 2._real32 + if(verbose_.gt.0) write(*,'(1X,"Avg min bulk bond: ",F0.3," Å")') avg_min_bond + if(verbose_.gt.0) write(*,'(1X,"Trans-interfacial scaling factor: ",F0.3)') this%separation_scale + if(this%shift_method.eq.-1) this%num_shifts = 1 + + + !--------------------------------------------------------------------------- + ! Gets bulk distribution functions (i.e. densities of neighbours) + ! ... if shift_method = 4 + !--------------------------------------------------------------------------- + allocate(lw_map(structure_lw%nspec,maxval(structure_lw%spec(:)%num,dim=1),2)) + allocate(up_map(structure_up%nspec,maxval(structure_up%spec(:)%num,dim=1),2)) + if(this%shift_method.eq.4.or.this%shift_method.eq.0)then + lw_map=0 + bulk_DON(1)%spec=gen_DON(structure_lw%lat,structure_lw,& + dist_max=this%bondlength_cutoff,& + scale_dist=.false.,& + norm=.true. & + ) + do is = 1, structure_lw%nspec + if(all(abs(bulk_DON(1)%spec(is)%atom(:,:)).lt.1._real32))then + bondlength = huge(0._real32) + do ia = 1, structure_lw%spec(is)%num + rtmp1 = modu(get_min_bond(structure_lw, is, ia)) + if(rtmp1.lt.bondlength) bondlength = rtmp1 + if(rtmp1.gt.this%bondlength_cutoff)then + write(filename,'("lw_DON_",I0,"_",I0,".dat")') is,ia + open(newunit=unit, file=filename) + do j=1,1000 + write(unit,*) & + (j-1)*this%bondlength_cutoff/1000,& + bulk_DON(1)%spec(is)%atom(ia,j) + end do + close(unit) + end if + end do + if(bondlength.gt.this%bondlength_cutoff)then + write(err_msg,'(A,I0,A,F0.3,A,F0.3)') & + "Minimum bondlength for species ", & + is, " in lower structure is ", bondlength, achar(10) // & + "To account for this, increase bondlength cutoff from ", & + this%bondlength_cutoff + call stop_program(trim(err_msg)) + end if + exit_code_ = 1 + return + end if + end do + up_map=0 + bulk_DON(2)%spec=gen_DON(structure_up%lat,structure_up,& + dist_max=this%bondlength_cutoff,& + scale_dist=.false.,& + norm=.true.) + do is = 1, structure_up%nspec + if(all(abs(bulk_DON(2)%spec(is)%atom(:,:)).lt.1._real32))then + bondlength = huge(0._real32) + do ia = 1, structure_up%spec(is)%num + rtmp1 = modu(get_min_bond(structure_up, is, ia)) + if(rtmp1.lt.bondlength) bondlength = rtmp1 + if(rtmp1.gt.this%bondlength_cutoff)then + write(filename,'("up_DON_",I0,"_",I0,".dat")') is,ia + open(newunit=unit, file=filename) + do j=1,1000 + write(unit,*) & + (j-1)*this%bondlength_cutoff/1000,& + bulk_DON(2)%spec(is)%atom(ia,j) + end do + close(unit) + end if + end do + if(bondlength.gt.this%bondlength_cutoff)then + write(err_msg,'(A,I0,A,F0.3,A,F0.3)') & + "Minimum bondlength for species ", & + is, " in upper structure is ", bondlength, achar(10) // & + "To account for this, increase bondlength cutoff from ", & + this%bondlength_cutoff + call stop_program(trim(err_msg)) + end if + exit_code_ = 1 + return + end if + end do + else + lw_map=-1 + up_map=-1 + end if + + + !--------------------------------------------------------------------------- + ! Check whether system appears layered + !--------------------------------------------------------------------------- + layered_axis_lw = get_layered_axis( structure_lw%lat, structure_lw ) + if(.not.this%is_layered_lw.and.layered_axis_lw.gt.0)then + ivtmp1 = 0 + ivtmp1(layered_axis_lw)=1 + if(this%ludef_is_layered_lw)then + write(err_msg,'("Lower crystal appears layered along axis ",I0,"\n& + &Partial layer terminations will be generated\n& + &We suggest using LW_MILLER =",3(1X,I1))') layered_axis_lw,ivtmp1 + call print_warning(trim(err_msg)) + else + write(err_msg,'("Lower crystal has been identified as layered\nalong",3(1X,I1),"\n& + &Confining crystal to this plane and\nstoichiometric terminations.\n& + &If you don''t want this, set\nLW_LAYERED = .FALSE.")') & + ivtmp1 + call print_warning(trim(err_msg)) + miller_lw=ivtmp1 + this%is_layered_lw=.true. + end if + elseif(this%is_layered_lw.and.layered_axis_lw.gt.0.and.all(miller_lw.eq.0))then + miller_lw(layered_axis_lw)=1 + end if + + layered_axis_up = get_layered_axis( structure_up%lat, structure_up ) + if(.not.this%is_layered_up.and.layered_axis_up.gt.0)then + ivtmp1=0 + ivtmp1(layered_axis_up)=1 + if(this%ludef_is_layered_up)then + write(err_msg,'("Upper crystal appears layered along axis ",I0,"\n& + &Partial layer terminations will be generated\n& + &We suggest using UP_MILLER =",3(1X,I1))') layered_axis_up,ivtmp1 + call print_warning(trim(err_msg)) + else + write(err_msg,'("Upper crystal has been identified as layered\nalong",3(1X,I1),"\n& + &Confining crystal to this plane and\nstoichiometric terminations.\n& + &If you don''t want this, set\nUP_LAYERED = .FALSE.")') & + ivtmp1 + call print_warning(trim(err_msg)) + miller_up=ivtmp1 + this%is_layered_up=.true. + end if + elseif(this%is_layered_up.and.layered_axis_up.gt.0.and.all(miller_up.eq.0))then + miller_up(layered_axis_up)=1 + end if + + + !--------------------------------------------------------------------------- + ! Finds and stores the best matches between the materials + !--------------------------------------------------------------------------- + num_structures_old = -1 + if(this%match_method.ne.0.and.(any(miller_lw.ne.0).or.any(miller_up.ne.0)))then + call stop_program('Cannot use LW_MILLER or UP_MILLER with IMATCH>0') + exit_code_ = 1 + return + elseif(this%match_method.ne.0)then + write(err_msg,'("& + &IMATCH /= 0 methods are experimental and may\n& + ¬ work as expected.\n& + &They are not intended to be thorough searches.\n& + &This method is not recommended unless you\n& + &are clear on its intended use and\n& + &limitations.& + &")') + call print_warning(trim(err_msg)) + tfmat = planecutter(structure_lw%lat,real(miller_lw,real32)) + call transformer(structure_lw,tfmat,lw_map) + end if + call SAV%init( & + this%tolerance, structure_lw%lat, structure_up%lat, & + this%max_num_matches, reduce_matches_ & + ) + select case(this%match_method) + case(0) + call lattice_matching(& + SAV, this%tolerance, & + structure_lw, structure_up, & + miller_lw = miller_lw, miller_up = miller_up, & + max_num_planes = this%max_num_planes, & + verbose = merge(1,verbose_,print_lattice_match_info_), & + tol_sym = this%tol_sym & + ) + case default + call SAV%constrain_axes(miller_lw, miller_up, verbose = verbose_) + call cyc_lat1(SAV, this%tolerance, this%match_method, verbose = verbose_) + end select + if(min(this%max_num_matches,SAV%nfit).eq.0)then + write(err_msg,'("No matches found between the two structures")') + call print_warning(trim(err_msg)) + return + else + if(verbose_.gt.0) write(*,'(1X,"Number of matches found: ",I0)')& + min(this%max_num_matches,SAV%nfit) + end if + if(verbose_.gt.0) write(*,'(1X,"Maximum number of generated interfaces will be: ",I0)')& + this%max_num_terms * this%num_shifts * this%max_num_matches + if(.not.generate_structures_)then + if(verbose_.gt.0) write(*,'(1X,"Told not to generate structures, just find matches.")') + return + end if + + +!!!----------------------------------------------------------------------------- +!!! Saves current directory and moves to new directory +!!!----------------------------------------------------------------------------- + if(interface_idx_.gt.0)then + intf_start=interface_idx_ + intf_end=interface_idx_ + if(verbose_.gt.0) write(*,'(1X,"Generating only interfaces for match ",I0)') interface_idx_ + else + intf_start=1 + intf_end=min(this%max_num_matches,SAV%nfit) + end if + iunique=0 +!!!----------------------------------------------------------------------------- +!!! Applies the best match transformations +!!!----------------------------------------------------------------------------- + intf_loop: do ifit = intf_start, intf_end + if(verbose_.gt.0) write(*,'("Fit number: ",I0)') ifit + call supercell_lw%copy(structure_lw) + call supercell_up%copy(structure_up) + if(allocated(t1lw_map)) deallocate(t1lw_map) + if(allocated(t1up_map)) deallocate(t1up_map) + allocate(t1lw_map,source=lw_map) + allocate(t1up_map,source=up_map) + + + !!----------------------------------------------------------------------- + !! Applies the best match transformations + !!----------------------------------------------------------------------- + call transformer(supercell_lw,real(SAV%tf1(ifit,:,:),real32),t1lw_map) + call transformer(supercell_up,real(SAV%tf2(ifit,:,:),real32),t1up_map) + + + !!----------------------------------------------------------------------- + !! Determines the cell change for the upper lattice to get the new DON + !!----------------------------------------------------------------------- + if(this%shift_method.eq.4)then + t1up_map=0 !TEMPORARY TO USE SUPERCELL DONS. + !DONsupercell_up%lat = matmul(mtmp1,inverse(real(SAV%tf2(ifit,:,:),real32))) + deallocate(bulk_DON(2)%spec) + bulk_DON(2)%spec=gen_DON(supercell_up%lat,supercell_up,& + dist_max=this%bondlength_cutoff,& + scale_dist=.false.,& + norm=.true.) + end if + + + !!----------------------------------------------------------------------- + !! Finds smallest thickness of the lower slab and increases to ... + !!user-defined thickness + !! SHOULD MAKE IT LATER MAKE DIFFERENT SETS OF THICKNESSES + !!----------------------------------------------------------------------- + confine%l=.false. + confine%axis=this%axis + confine%laxis=.false. + confine%laxis(this%axis)=.true. + if(allocated(trans)) deallocate(trans) + allocate(trans(minval(supercell_lw%spec(:)%num+2),3)) + call gldfnd(confine, supercell_lw, supercell_lw, trans, ntrans, this%tol_sym) + tfmat(:,:)=0._real32 + tfmat(1,1)=1._real32 + tfmat(2,2)=1._real32 + if(ntrans.eq.0)then + tfmat(3,3)=1._real32 + else + itmp1=minloc(abs(trans(:ntrans,this%axis)),dim=1,& + mask=abs(trans(:ntrans,this%axis)).gt.1.D-3/modu(supercell_lw%lat(this%axis,:))) + tfmat(3,:)=trans(itmp1,:) + end if + if(all(abs(tfmat(3,:)).lt.1.E-5_real32)) tfmat(3,3) = 1._real32 + call transformer(supercell_lw,tfmat,t1lw_map) + ! check the stoichiometry ratios are still maintained + if(.not.compare_stoichiometry(structure_lw,supercell_lw))then + write(0,'(1X,"ERROR: Internal error in generate_interfaces")') + write(0,'(2X,"& + &The gldfnd subroutine could not reproduce a valid primitive & + &cell for the lower material on match ",I0)') ifit + if(verbose_.gt.1)then + call err_abort_print_struc(supercell_lw, "broken_primitive.vasp", & + "Code exiting due to IPRINT = 1") + end if + write(0,'(2X,"Skipping this lattice match")') + cycle intf_loop + end if + + + !!----------------------------------------------------------------------- + !! Finds all terminations parallel to the surface plane + !!----------------------------------------------------------------------- + if(allocated(lw_term%arr)) deallocate(lw_term%arr) + lw_term = get_termination_info( & + supercell_lw, this%axis, & + verbose = merge(1,verbose_,print_termination_info_), & + tol_sym = this%tol_sym, & + layer_sep = this%layer_separation_cutoff(1), & + exit_code = exit_code_ & + ) + if(exit_code_.ne.0)then + write(err_msg,'(A,I0,A)') & + "The termination generator failed with exit code ", exit_code_ + if(break_on_fail_)then + call stop_program(trim(err_msg)) + return + end if + end if + if(lw_term%nterm .eq. 0)then + write(0,'("WARNING: & + &No terminations found for lower material Miller plane & + &(",3(1X,I0)," )")' & + ) SAV%tf1(ifit,3,1:3) + cycle intf_loop + end if + if(any(surface_lw_.gt.lw_term%nterm))then + write(err_msg, '("surface_lw_ACE VALUES INVALID!\nOne or more value & + &exceeds the maximum number of terminations in the & + &structure.\n& + & Supplied values: ",I0,1X,I0,"\n& + & Maximum allowed: ",I0)') surface_lw_, lw_term%nterm + call err_abort(trim(err_msg),fmtd=.true.) + return + end if + + + !!----------------------------------------------------------------------- + !! Sort out ladder rungs (checks whether the material is centrosymmetric) + !!----------------------------------------------------------------------- + !call setup_ladder(supercell_lw%lat,supercell_lw,this%axis,lw_term) + if(sum(lw_term%arr(:)%natom)*lw_term%nstep.ne.supercell_lw%natom)then + write(err_msg, '("Number of atoms in lower layers not correct: "& + &I0,2X,I0)') sum(lw_term%arr(:)%natom)*lw_term%nstep,supercell_lw%natom + call err_abort(trim(err_msg),fmtd=.true.) + return + end if + call set_layer_tol(lw_term) + + + !!----------------------------------------------------------------------- + !! Defines height of lower slab from user-defined values + !!----------------------------------------------------------------------- + call build_slab_supercell(supercell_lw,t1lw_map,lw_term,surface_lw_,& + height_lw,num_layers_lw_, thickness_lw_,num_cells_lw,& + term_lw_start_idx,term_lw_end_idx,term_lw_step & + ) + if(term_lw_end_idx.gt.this%max_num_terms) term_lw_end_idx = this%max_num_terms + + + !!----------------------------------------------------------------------- + !! Finds smallest thickness of the upper slab and increases to ... + !! ... user-defined thickness + !! SHOULD MAKE IT LATER MAKE DIFFERENT SETS OF THICKNESSES + !!----------------------------------------------------------------------- + deallocate(trans) + allocate(trans(minval(supercell_up%spec(:)%num+2),3)) + call gldfnd(confine, supercell_up, supercell_up, trans,ntrans, this%tol_sym) + tfmat(:,:)=0._real32 + tfmat(1,1)=1._real32 + tfmat(2,2)=1._real32 + if(ntrans.eq.0)then + tfmat(3,3)=1._real32 + else + itmp1=minloc(abs(trans(:ntrans,this%axis)),dim=1,& + mask=abs(trans(:ntrans,this%axis)).gt.1.D-3/modu(supercell_lw%lat(this%axis,:))) + tfmat(3,:)=trans(itmp1,:) + end if + if(all(abs(tfmat(3,:)).lt.1.E-5_real32)) tfmat(3,3) = 1._real32 + call transformer(supercell_up,tfmat,t1up_map) + ! check the stoichiometry ratios are still maintained + if(.not.compare_stoichiometry(structure_up,supercell_up))then + write(0,'(1X,"ERROR: Internal error in generate_interfaces")') + write(0,'(2X,"& + &The gldfnd subroutine could not reproduce a valid primitive & + &cell for the upper material on match ",I0)') ifit + if(verbose_.gt.1)then + call err_abort_print_struc(supercell_up, "broken_primitive.vasp", & + "Code exiting due to IPRINT = 1") + end if + write(0,'(2X,"Skipping this lattice match")') + cycle intf_loop + end if + + + !!----------------------------------------------------------------------- + !! Finds all supercell_up%lat unique terminations parallel to the surface plane + !!----------------------------------------------------------------------- + if(allocated(up_term%arr)) deallocate(up_term%arr) + up_term = get_termination_info( & + supercell_up, this%axis, & + verbose = merge(1,verbose_,print_termination_info_), & + tol_sym = this%tol_sym, & + layer_sep = this%layer_separation_cutoff(2), & + exit_code = exit_code_ & + ) + if(exit_code_.ne.0)then + write(err_msg,'(A,I0,A)') & + "The termination generator failed with exit code ", exit_code_ + if(break_on_fail_)then + call stop_program(trim(err_msg)) + return + end if + end if + if(up_term%nterm .eq. 0)then + write(0,'("WARNING: & + &No terminations found for upper material Miller plane & + &(",3(1X,I0)," )")' & + ) SAV%tf2(ifit,3,1:3) + cycle intf_loop + end if + if(any(surface_up_.gt.up_term%nterm))then + write(err_msg, '("surface_up_ACE VALUES INVALID!\nOne or more value & + &exceeds the maximum number of terminations in the & + &structure.\n& + & Supplied values: ",I0,1X,I0,"\n& + & Maximum allowed: ",I0)') surface_up_, up_term%nterm + call err_abort(trim(err_msg),fmtd=.true.) + return + end if + + + !!----------------------------------------------------------------------- + !! Sort out ladder rungs (checks whether the material is centrosymmetric) + !!----------------------------------------------------------------------- + !call setup_ladder(supercell_up%lat,supercell_up,this%axis,up_term) + if(sum(up_term%arr(:)%natom)*up_term%nstep.ne.supercell_up%natom)then + write(err_msg, '("Number of atoms in upper layers not correct: "& + &I0,2X,I0)') sum(up_term%arr(:)%natom)*up_term%nstep,supercell_up%natom + call stop_program(trim(err_msg)) + return + end if + call set_layer_tol(up_term) + + + !!----------------------------------------------------------------------- + !! Defines height of upper slab from user-defined values + !!----------------------------------------------------------------------- + call build_slab_supercell(supercell_up,t1up_map,up_term,surface_up_,& + height_up,num_layers_up_, thickness_up_, num_cells_up,& + term_up_start_idx,term_up_end_idx,term_up_step & + ) + if(term_up_end_idx.gt.this%max_num_terms) term_up_end_idx = this%max_num_terms + + + !!----------------------------------------------------------------------- + !! Print termination plane locations + !!----------------------------------------------------------------------- + if(verbose_.gt.0) write(*,'(1X,"Number of unique terminations: ",I0,2X,I0)') & + lw_term%nterm,up_term%nterm + + !!----------------------------------------------------------------------- + !! Cycle over terminations of both materials and generates interfaces ... + !! ... composed of all of the possible combinations of the two + !!----------------------------------------------------------------------- + lw_term_loop: do iterm_lw = term_lw_start_idx, term_lw_end_idx, term_lw_step + call slab_lw%copy(supercell_lw) + if(allocated(t2lw_map)) deallocate(t2lw_map) + allocate(t2lw_map,source=t1lw_map) + !!-------------------------------------------------------------------- + !! Shifts lower material to specified termination + !!-------------------------------------------------------------------- + call cut_slab_to_height(slab_lw,t2lw_map,lw_term,[iterm_lw,surface_lw_(2)],& + thickness_lw_, num_cells_lw, num_layers_lw_, height_lw,& + "lw",lcycle, & + vacuum = this%vacuum_gap & + ) + if(lcycle) cycle lw_term_loop + + + !!-------------------------------------------------------------------- + !! Cycles over terminations of upper material + !!-------------------------------------------------------------------- + up_term_loop: do iterm_up = term_up_start_idx, term_up_end_idx, term_up_step + call slab_up%copy(supercell_up) + if(allocated(t2up_map)) deallocate(t2up_map) + allocate(t2up_map,source=t1up_map) + call cut_slab_to_height(slab_up,t2up_map,up_term,[iterm_up,surface_up_(2)],& + thickness_up_, num_cells_up, num_layers_up_, height_up,& + "up",lcycle, & + vacuum = this%vacuum_gap & + ) + if(lcycle) cycle up_term_loop + + + !!----------------------------------------------------------------- + !! Checks stoichiometry + !!----------------------------------------------------------------- + if(slab_lw%nspec.ne.structure_lw%nspec.or.any(& + (structure_lw%spec(1)%num*slab_lw%spec(:)%num)& + /slab_lw%spec(1)%num.ne.structure_lw%spec(:)%num))then + write(*,'("WARNING: This lower surface termination is not & + &stoichiometric")') + if(this%is_layered_lw)then + write(*,'(2X,"As lower structure is layered, stoichiometric & + &surfaces are required.")') + write(*,'(2X,"Skipping this termination...")') + cycle lw_term_loop + elseif(this%require_stoichiometry_lw)then + write(*,'(2X,"Skipping this termination...")') + cycle lw_term_loop + end if + end if + if(slab_up%nspec.ne.structure_up%nspec.or.any(& + (structure_up%spec(1)%num*slab_up%spec(:)%num)& + /slab_up%spec(1)%num.ne.structure_up%spec(:)%num))then + write(*,'("WARNING: This upper surface termination is not & + &stoichiometric")') + if(this%is_layered_up)then + write(*,'(2X,"As upper structure is layered, stoichiometric & + &surfaces are required.")') + write(*,'(2X,"Skipping this termination...")') + cycle up_term_loop + elseif(this%require_stoichiometry_up)then + write(*,'(2X,"Skipping this termination...")') + cycle up_term_loop + end if + end if + + + !------------------------------------------------------------------ + ! Use the bulk moduli to determine the strain sharing + !------------------------------------------------------------------ + if(allocated(this%elastic_tensor_lw).and. & + allocated(this%elastic_tensor_up))then + if( all(shape(this%elastic_tensor_lw) .ne. & + shape(this%elastic_tensor_up)) )then + write(err_msg,'(A)') & + "Inconsistent representation of elastic constants." + call stop_program(trim(err_msg)) + return + end if + select case(size(this%elastic_tensor_lw)) + case(1) + if( abs(this%elastic_tensor_lw(1,1)).gt.0.E0 .and. & + abs(this%elastic_tensor_up(1,1)).gt.0.E0 & + )then + call share_strain_scalar(slab_lw,slab_up,& + this%elastic_tensor_lw(1,1), & + this%elastic_tensor_up(1,1), & + lcompensate = this%compensate_normal & + ) + end if + case(6) + call share_strain_tensor(slab_lw,slab_up,& + this%elastic_tensor_lw, & + this%elastic_tensor_up, & + lcompensate = this%compensate_normal & + ) + case default + write(err_msg,'("Elastic constants not yet set up to handle & + &the full tensor.")') + call stop_program(trim(err_msg)) + exit_code_ = 1 + return + end select + elseif(allocated(this%elastic_tensor_lw).neqv. & + allocated(this%elastic_tensor_up))then + write(err_msg,'(A)') & + "Elastic constants not set up for both materials." + call stop_program(trim(err_msg)) + exit_code_ = 1 + return + end if + + + + !------------------------------------------------------------------ + ! Merge the two bases and lattices and define the interface loc + !------------------------------------------------------------------ + intf_basis = basis_stack(& + basis1 = slab_lw, basis2 = slab_up, & + axis = this%axis, offset = init_offset(:), & + map1 = t2lw_map, map2 = t2up_map & + ) + intf_loc(1) = ( modu(slab_lw%lat(this%axis,:)) + 0.5_real32*init_offset(this%axis) - & + this%vacuum_gap)/modu(intf_basis%lat(this%axis,:)) + intf_loc(2) = ( modu(slab_lw%lat(this%axis,:)) + modu(slab_up%lat(this%axis,:)) + & + 1.5_real32*init_offset(this%axis) - 2._real32*this%vacuum_gap )/modu(intf_basis%lat(this%axis,:)) + if(verbose_.ge.1)then + write(0,*) "interface:",intf_loc + if(verbose_.eq.1.and.iunique.eq.icheck_term_pair_-1)then + ! call chdir(intf_dir) + call err_abort_print_struc(slab_lw,"lw_term.vasp",& + "",.false.) + call err_abort_print_struc(slab_up,"up_term.vasp",& + "As IPRINT = 1 and ICHECK has been set, & + &code is now exiting...") + elseif(verbose_.eq.2.and.iunique.eq.icheck_term_pair_-1)then + ! call chdir(intf_dir) + call err_abort_print_struc(intf_basis,"test_intf.vasp",& + "As IPRINT = 2 and ICHECK has been set, & + &code is now exiting...") + end if + end if + + + + !------------------------------------------------------------------ + ! Saves current directory and moves to new directory + !------------------------------------------------------------------ + if(this%num_structures.gt.num_structures_old) iunique = iunique + 1 + num_structures_old = this%num_structures + + + !------------------------------------------------------------------ + ! Write information of current match to file in save directory + !------------------------------------------------------------------ + ! call output_intf_data(SAV, ifit, lw_term, iterm_lw, up_term, iterm_up,& + ! this%use_pricel_lw, this%use_pricel_up) + struc_data = struc_data_type( & + match_idx = ifit, & + match_and_term_idx = iunique, & + from_pricel_lw = this%use_pricel_lw, & + from_pricel_up = this%use_pricel_up, & + term_lw_idx = [iterm_lw,max(surface_lw_(2),iterm_lw)], & + term_up_idx = [iterm_up,max(surface_up_(2),iterm_up)], & + term_lw_bounds = [ lw_term%arr(iterm_lw)%hmin, & + lw_term%arr(iterm_lw)%hmax, & + lw_term%arr(max(surface_lw_(2),iterm_lw))%hmin, & + lw_term%arr(max(surface_lw_(2),iterm_lw))%hmax & + ], & + term_up_bounds = [ up_term%arr(iterm_up)%hmin, & + up_term%arr(iterm_up)%hmax, & + up_term%arr(max(surface_up_(2),iterm_up))%hmin, & + up_term%arr(max(surface_up_(2),iterm_up))%hmax & + ], & + term_lw_natom = [ lw_term%arr(iterm_lw)%natom, & + lw_term%arr(max(surface_lw_(2),iterm_lw))%natom & + ], & + term_up_natom = [ up_term%arr(iterm_up)%natom, & + up_term%arr(max(surface_up_(2),iterm_up))%natom & + ], & + approx_thickness_lw = max(thickness_lw_,height_lw), & + approx_thickness_up = max(thickness_up_,height_up), & + transform_lw = SAV%tf1(ifit,:,:), & + transform_up = SAV%tf2(ifit,:,:), & + mismatch = SAV%tol(ifit,:3) & + ) + + + !------------------------------------------------------------------ + ! Generate shifts and swaps and prints the subsequent structures + !------------------------------------------------------------------ + call this%generate_perturbations( & + intf_basis, intf_loc, avg_min_bond, & + bulk_DON, & + struc_data, & + print_shift_info_, & + seed_arr, & + verbose_, & + exit_code_, & + t2lw_map & + ) + + if(this%num_structures.ge.this%max_num_structures) exit intf_loop + + if(ludef_surface_up) exit up_term_loop + end do up_term_loop + if(ludef_surface_lw) exit lw_term_loop + end do lw_term_loop + + end do intf_loop + + if(present(exit_code)) exit_code = exit_code_ + + end subroutine generate_interfaces +!############################################################################### + + +!!!############################################################################# +!!! Takes input interface structure and generates a set of shifts and swaps. +!!!############################################################################# +!!! ISWAP METHOD NOT YET SET UP + subroutine generate_shifts_and_swaps( & + this, basis, intf_loc, bond, bulk_DON, struc_data, print_shift_info, & + seed_arr, verbose, exit_code, map & + ) + implicit none + class(artemis_generator_type), intent(inout) :: this + type(basis_type), intent(in) :: basis + real(real32), dimension(2), intent(in) :: intf_loc + real(real32), intent(in) :: bond + type(bulk_DON_type), dimension(2), intent(in) :: bulk_DON + !! Distribution functions for the lower and upper bulk structures + type(struc_data_type), intent(in) :: struc_data + logical, intent(in) :: print_shift_info + integer, dimension(:), intent(in) :: seed_arr + integer, intent(in) :: verbose + integer, intent(inout) :: exit_code + integer, dimension(:,:,:), optional, intent(in) :: map + + integer :: iaxis,k,l + integer :: ngen_swaps,nswaps_per_cell + real(real32) :: rtmp1 + type(basis_type) :: tbas + type(bond_type) :: min_bond + type(struc_data_type) :: struc_data_shift + type(struc_data_type), dimension(:), allocatable :: struc_data_swaps + character(len=256) :: err_msg + integer, dimension(3) :: abc + real(real32), dimension(3) :: toffset + type(basis_type), allocatable, dimension(:) :: basis_arr + real(real32), allocatable, dimension(:,:) :: output_shifts + + + +!!!----------------------------------------------------------------------------- +!!! Sets up shift axis +!!!----------------------------------------------------------------------------- + abc = [ 1, 2, 3 ] + abc = cshift(abc,this%axis) + + +!!!----------------------------------------------------------------------------- +!!! Generates sets of shifts based on shift version +!!!----------------------------------------------------------------------------- + if(this%shift_method.eq.0.or.this%shift_method.eq.1) allocate(output_shifts(this%num_shifts,3)) + select case(this%shift_method) + case(1) + output_shifts(1,:3)=0._real32 + do k=2,this%num_shifts + do iaxis = 1, 2 + call random_number(output_shifts(k,iaxis)) + end do + end do + case(2) + output_shifts = get_fit_shifts(& + lat=basis%lat,bas=basis,& + bond=bond,& + axis=this%axis,& + intf_loc=intf_loc,& + depth=this%interface_depth,& + nstore=this%num_shifts) + case(3) + output_shifts = get_descriptive_shifts(& + lat=basis%lat,bas=basis,& + bond=bond,& + axis=this%axis,& + intf_loc=intf_loc,& + depth=this%interface_depth, & + c_scale=this%separation_scale,& + nstore=this%num_shifts,lprint=print_shift_info) + case(4) + if(present(map))then + output_shifts = get_shifts_DON(& + bas=basis,& + axis=this%axis,& + intf_loc=intf_loc,& + nstore=this%num_shifts, & + c_scale=this%separation_scale, & + offset=this%shifts(1,:3),& + verbose=merge(1,verbose,print_shift_info), & + bulk_DON=bulk_DON,bulk_map=map,& + max_bondlength=this%bondlength_cutoff,& + tol_sym=this%tol_sym) + else + output_shifts = get_shifts_DON(& + bas=basis,& + axis=this%axis,& + intf_loc=intf_loc,& + nstore=this%num_shifts, & + c_scale=this%separation_scale, & + offset=this%shifts(1,:3),& + verbose=merge(1,verbose,print_shift_info), & + max_bondlength=this%bondlength_cutoff,& + tol_sym=this%tol_sym) + end if + if(size(output_shifts(:,1)).eq.0)then + write(0,'(2X,"No shifts were identified with ISHIFT = 4 for this lattice match")') + write(0,'(2X,"We suggest increasing MBOND_MAXLEN to find shifts")') + write(0,'("Skipping interface...")') + return + end if + case default + if(.not.allocated(output_shifts)) allocate(output_shifts(1,3)) + output_shifts(:,:) = this%shifts + do iaxis = 1, 2 + output_shifts(1,iaxis) = output_shifts(1,iaxis)!/modu(lat(iaxis,:)) + end do + end select + if(this%shift_method.gt.0)then + output_shifts(:,this%axis) = output_shifts(:,this%axis) * modu(basis%lat(this%axis,:)) + end if + + +!!!----------------------------------------------------------------------------- +!!! Prints number of shifts to terminal +!!!----------------------------------------------------------------------------- + if(verbose.gt.0) write(*,'(3X,"Number of unique shifts structures: ",I0)') size(output_shifts,1) + + +!!!----------------------------------------------------------------------------- +!!! Determines number of swaps across the interface +!!!----------------------------------------------------------------------------- + nswaps_per_cell = nint(this%swap_density*get_area([basis%lat(abc(1),:)],[basis%lat(abc(2),:)])) + if(this%swap_method.ne.0)then + if(verbose.gt.0) write(*,& + '(" Generating ",I0," swaps per structure ")') nswaps_per_cell + end if + + +!!!----------------------------------------------------------------------------- +!!! Prints each unique shift structure +!!!----------------------------------------------------------------------------- + shift_loop: do k = 1, size(output_shifts,1), 1 + call tbas%copy(basis) + toffset=output_shifts(k,:3) + do iaxis=1,2 + call shift_region(tbas,this%axis,& + intf_loc(1),intf_loc(2),& + shift_axis=iaxis,shift=toffset(iaxis),renorm=.true.) + end do + rtmp1=modu(tbas%lat(this%axis,:)) + call set_vacuum(& + basis=tbas,& + axis=this%axis,loc=maxval(intf_loc(:)),& + vac=toffset(this%axis)) + rtmp1=minval(intf_loc(:))*rtmp1/modu(tbas%lat(this%axis,:)) + call set_vacuum(& + basis=tbas,& + axis=this%axis,loc=rtmp1,& + vac=toffset(this%axis)) + min_bond = get_shortest_bond(tbas) + if(min_bond%length.le.1.5_real32)then + write(err_msg,'("Smallest bond in the interface structure is\nless than 1.5 Å.")') + call print_warning(trim(err_msg)) + write(*,'(2X,"bond length: ",F9.6)') min_bond%length + write(*,'(2X,"atom 1:",I4,2X,I4)') min_bond%atoms(1,:) + write(*,'(2X,"atom 2:",I4,2X,I4)') min_bond%atoms(2,:) + end if + + + !!----------------------------------------------------------------------- + !! Merges lower and upper materials + !! Writes interfaces to output directories + !!----------------------------------------------------------------------- + struc_data_shift = struc_data + struc_data_shift%shift_idx = k + struc_data_shift%shift = toffset + this%structures = [ this%structures, tbas ] + this%num_structures = size(this%structures, dim = 1) + if(.not.allocated(this%structure_data))then + this%structure_data = [ struc_data_shift ] + else + this%structure_data = [ this%structure_data, struc_data_shift ] + end if + if(this%num_structures.ge.this%max_num_structures) return + + + !!----------------------------------------------------------------------- + !! Performs swaps within the shifted structures if requested + !!----------------------------------------------------------------------- + if_swap: if(this%swap_method.ne.0)then + basis_arr = rand_swapper(tbas%lat,tbas,this%axis,this%swap_depth,& + nswaps_per_cell,this%num_swaps,intf_loc,this%swap_method,& + seed_arr, & + tol_sym = this%tol_sym, & + verbose = verbose, & + sigma=this%swap_sigma, & + require_mirror=this%require_mirror_swaps & + ) + ngen_swaps = this%num_swaps + LOOPswaps: do l=1,this%num_swaps + if (basis_arr(l)%nspec.eq.0) then + ngen_swaps = l - 1 + exit LOOPswaps + end if + end do LOOPswaps + if(ngen_swaps.eq.0)then + exit if_swap + end if + if(allocated(struc_data_swaps)) deallocate(struc_data_swaps) + allocate(struc_data_swaps(ngen_swaps)) + do l=1,ngen_swaps + struc_data_swaps(l) = struc_data_shift + struc_data_swaps(l)%swap_idx = l + struc_data_swaps(l)%swap_density = this%swap_density + ! struc_data_swaps(l)%approx_eff_swap_conc = + end do + this%structures = [ this%structures, basis_arr(1:ngen_swaps) ] + this%structure_data = [ this%structure_data, struc_data_swaps ] + deallocate(basis_arr) + end if if_swap + + + end do shift_loop + + end subroutine generate_shifts_and_swaps +!!!############################################################################# + + +!############################################################################### + subroutine write_match_and_term_data(this, idx, directory, filename) + !! This subroutine writes the match and termination data to a file + implicit none + + ! Arguments + class(artemis_generator_type), intent(in) :: this + !! Instance of artemis generator type + integer, intent(in) :: idx + !! List of indices for the structures to be written + character(len=*), intent(in) :: directory + !! Directory where the files will be written + character(len=*), intent(in) :: filename + !! Name of the file to be written + + ! Local variables + integer :: unit + + + open(newunit=unit, file=trim(adjustl(directory))//"/"//trim(adjustl(filename))) + associate( struc_data => this%structure_data(idx) ) + write(unit,'("Lower material primitive cell used: ",L1)') struc_data%from_pricel_lw + write(unit,'("Upper material primitive cell used: ",L1)') struc_data%from_pricel_up + write(unit,*) + write(unit,'("Match and termination identifier: ",I0)') struc_data%match_and_term_idx + write(unit,'("Lattice match: ",I0)') struc_data%match_idx + write(unit,'((1X,3(3X,A1),3X,3(3X,A1)),3(/,2X,3(I3," "),3X,3(I3," ")))') & + "a", "b", "c", "a", "b", "c", & + struc_data%transform_lw(1,1:3), struc_data%transform_up(1,1:3), & + struc_data%transform_lw(2,1:3), struc_data%transform_up(2,1:3), & + struc_data%transform_lw(3,1:3), struc_data%transform_up(3,1:3) + write(unit,'(" vector mismatch (%) = ",F0.9)') struc_data%mismatch(1) + write(unit,'(" angle mismatch (°) = ",F0.9)') struc_data%mismatch(2) * 180._real32 / pi + write(unit,'(" area mismatch (%) = ",F0.9)') struc_data%mismatch(3) + write(unit,*) + write(unit,'(" Lower crystal Miller plane: ",3(I3," "))') struc_data%transform_lw(3,1:3) + write(unit,'(" Lower termination")') + write(unit,'(1X,"Term.",3X,"Min layer loc",3X,"Max layer loc",3X,"no. atoms")') + write(unit,'(1X,I3,8X,F7.5,9X,F7.5,8X,I3)') & + struc_data%term_lw_idx(1), & + struc_data%term_lw_bounds(1:2), & + struc_data%term_lw_natom(1) + write(unit,'(1X,I3,8X,F7.5,9X,F7.5,8X,I3)') & + struc_data%term_lw_idx(2), & + struc_data%term_lw_bounds(3:4), & + struc_data%term_lw_natom(2) + write(unit,*) + write(unit,'(" Upper crystal Miller plane: ",3(I3," "))') struc_data%transform_up(3,1:3) + write(unit,'(" Upper termination")') + write(unit,'(1X,"Term.",3X,"Min layer loc",3X,"Max layer loc",3X,"no. atoms")') + write(unit,'(1X,I3,8X,F7.5,9X,F7.5,8X,I3)') & + struc_data%term_up_idx(1), & + struc_data%term_up_bounds(1:2), & + struc_data%term_up_natom(1) + write(unit,'(1X,I3,8X,F7.5,9X,F7.5,8X,I3)') & + struc_data%term_up_idx(2), & + struc_data%term_up_bounds(3:4), & + struc_data%term_up_natom(2) + write(unit,*) + end associate + + close(unit) + + end subroutine write_match_and_term_data +!############################################################################### + + +!############################################################################### + subroutine write_shift_data(this, idx_list, directory, filename) + !! This subroutine writes the shift data to a file + implicit none + + ! Arguments + class(artemis_generator_type), intent(in) :: this + !! Instance of artemis generator type + integer, dimension(:), intent(in) :: idx_list + !! List of indices for the structures to be written + character(len=*), intent(in) :: directory + !! Directory where the files will be written + character(len=*), intent(in) :: filename + !! Name of the file to be written + + ! Local variables + integer :: i + integer :: unit + + + open(newunit=unit, file=trim(adjustl(directory))//"/"//trim(adjustl(filename))) + write(unit, & + '("# shift_num shift (a,b,c) units=(direct,direct,Å)")') + do i = 1, size(idx_list), 1 + write(unit,'(2X,I0.2,15X,"(",2(" ",F9.6,", ")," ",F9.6," )")') & + i, this%structure_data(idx_list(i))%shift + end do + close(unit) + + end subroutine write_shift_data +!############################################################################### + +end module artemis__generator diff --git a/src/fortran/lib/mod_geom_rw.f90 b/src/fortran/lib/mod_geom_rw.f90 new file mode 100644 index 0000000..f6ab779 --- /dev/null +++ b/src/fortran/lib/mod_geom_rw.f90 @@ -0,0 +1,2171 @@ +!!!############################################################################# +!!! Code written by Ned Thaddeus Taylor and Francis Huw Davies +!!! Code part of the ARTEMIS group (Hepplestone research group). +!!! Think Hepplestone, think HRG. +!!!############################################################################# +!!! Module made to read and write structure input files +!!! Currently supports: +!!! -VASP +!!! -Quantum Espresso +!!! -CASTEP +!!! -xyz (read only) +!!!############################################################################# +module artemis__geom_rw + use artemis__constants, only: real32, pi + use artemis__misc, only: to_upper, to_lower, jump, icount, strip_null + use artemis__io_utils, only: print_warning, stop_program + use misc_linalg, only: modu, inverse_3x3 + implicit none + + private + + public :: igeom_input, igeom_output + public :: basis_type, species_type + public :: geom_read, geom_write + public :: get_element_properties + + + integer :: igeom_input = 1 + !! geometry input file format + !! 1 = VASP + !! 2 = CASTEP + !! 3 = Quantum Espresso + !! 4 = CRYSTAL + !! 5 = XYZ + !! 6 = extended XYZ + integer :: igeom_output = 1 + !! geometry output file format + + type :: species_type + !! Derived type to store information about a species/element. + real(real32), allocatable ,dimension(:,:) :: atom + !! The atomic positions of the species. + real(real32) :: mass + !! The mass of the species. + real(real32) :: charge + !! The charge of the species. + real(real32) :: radius + !! The radius of the species. + character(len=3) :: name + !! The name of the species. + integer :: num + !! The number of atoms of this species. + end type species_type + type :: basis_type + !! Derived type to store information about a basis. + type(species_type), allocatable, dimension(:) :: spec + !! Information about each species in the basis. + integer :: nspec = 0 + !! The number of species in the basis. + integer :: natom = 0 + !! The number of atoms in the basis. + real(real32) :: energy = 0._real32 + !! The energy of the basis. + real(real32) :: lat(3,3) = 0._real32 + !! The lattice vectors of the basis. + logical :: lcart = .false. + !! Boolean whether the basis is in cartesian coordinates. + logical, dimension(3) :: pbc = .true. + !! Boolean whether the basis has periodic boundary conditions. + character(len=128) :: sysname = "default" + !! The name of the system. + contains + procedure, pass(this) :: allocate_species + !! Procedure to allocate the species in the basis. + procedure, pass(this) :: convert + !! Procedure to convert the basis to cartesian coordinates. + procedure, pass(this) :: change_lattice + !! Procedure to change the lattice of the basis. + procedure, pass(this) :: normalise + !! Procedure to normalise the basis. + procedure, pass(this) :: copy + !! Procedure to copy the basis. + procedure, pass(this) :: get_lattice_constants + !! Procedure to get the lattice constants of the basis. + procedure, pass(this) :: remove_atom + !! Procedure to remove an atom from the basis. + procedure, pass(this) :: remove_atoms + !! Procedure to remove atoms from the basis. + end type basis_type + + + interface basis_type + module function init_basis_type(basis) result(output) + !! Initialise the basis type. + type(basis_type), intent(in), optional :: basis + !! Optional. Basis to copy. + type(basis_type) :: output + !! The basis to initialise. + end function init_basis_type + end interface basis_type + + + +contains + +!############################################################################### + module function init_basis_type(basis) result(output) + !! Initialise the basis type. + implicit none + + ! Arguments + type(basis_type), intent(in), optional :: basis + !! Optional. Basis to copy. + type(basis_type) :: output + !! The basis to initialise. + + if(present(basis)) call output%copy(basis) + + end function init_basis_type +!############################################################################### + + +!############################################################################### + subroutine allocate_species( & + this, num_species, & + species_symbols, species_count, atoms ) + !! Allocate the species in the basis. + implicit none + + ! Arguments + class(basis_type), intent(inout) :: this + !! Parent. The basis to allocate the species in. + integer, intent(in), optional :: num_species + !! Optional. The number of species in the basis. + character(3), dimension(:), intent(in), optional :: species_symbols + !! Optional. The symbols of the species. + integer, dimension(:), intent(in), optional :: species_count + !! Optional. The number of atoms of each species. + real(real32), dimension(:,:), intent(in), optional :: atoms + !! Optional. The atomic positions of the species. + + ! Local variables + integer :: i, istart, iend + !! Loop index. + + if(present(num_species)) this%nspec = num_species + + if(allocated(this%spec)) deallocate(this%spec) + allocate(this%spec(this%nspec)) + + species_check: if(present(species_symbols))then + if(size(species_symbols).ne.this%nspec) exit species_check + this%spec(:)%name = species_symbols + end if species_check + + natom_check: if(present(species_count))then + if(size(species_count).ne.this%nspec) exit natom_check + this%spec(:)%num = species_count + istart = 1 + do i = 1, this%nspec + iend = istart + this%spec(i)%num - 1 + allocate(this%spec(i)%atom(this%spec(i)%num,3)) + if(present(atoms))then + this%spec(i)%atom = atoms(istart:iend,:3) + end if + istart = iend + 1 + end do + end if natom_check + + do i = 1, this%nspec + call get_element_properties( & + this%spec(i)%name, & + mass = this%spec(i)%mass, & + charge = this%spec(i)%charge, & + radius = this%spec(i)%radius ) + end do + + end subroutine allocate_species +!############################################################################### + + +!############################################################################### + subroutine geom_read(UNIT, basis, length, iostat) + !! Read geometry from a file. + implicit none + + ! Arguments + integer, intent(in) :: UNIT + !! The unit number of the file to read from. + type(basis_type), intent(out) :: basis + !! The basis to read the geometry into. + integer, optional, intent(in) :: length + !! Optional. The dimension of the basis atom positions. + integer, optional, intent(out) :: iostat + !! Optional. The I/O status of the read. + + ! Local variables + integer :: i + !! Loop index. + integer :: length_ + !! The dimension of the basis atom positions. + integer :: iostat_ + !! The I/O status of the read. + + + length_ = 3 + iostat_ = 0 + if(present(length)) length_=length + + select case(igeom_input) + case(1) + call VASP_geom_read(UNIT, basis, length_, iostat_) + case(2) + call CASTEP_geom_read(UNIT, basis, length_) + case(3) + call QE_geom_read(UNIT, basis, length_) + case(4) + call stop_program("Not yet set up for CRYSTAL") + return + case(5) + call XYZ_geom_read(UNIT, basis, length_, iostat_) + call print_warning("XYZ file format does not contain lattice data") + case(6) + call extXYZ_geom_read(UNIT, basis, length_, iostat_) + end select + if(iostat_.ne.0) then + if(present(iostat)) iostat = iostat_ + return + else + if(present(iostat)) iostat = 0 + end if + if(length_.eq.4)then + do i = 1, basis%nspec + basis%spec(i)%atom(:,4)=1._real32 + end do + end if + do i = 1, basis%nspec + call get_element_properties( & + basis%spec(i)%name, & + mass = basis%spec(i)%mass, & + charge = basis%spec(i)%charge, & + radius = basis%spec(i)%radius ) + end do + + end subroutine geom_read +!############################################################################### + + +!############################################################################### + subroutine geom_write(UNIT, basis) + !! Write geometry to a file. + implicit none + + ! Arguments + integer, intent(in) :: UNIT + !! The unit number of the file to write to. + class(basis_type), intent(in) :: basis + !! The basis to write the geometry from. + + ! MAKE IT CHANGE HERE IF USER SPECIFIES LCART OR NOT + ! AND GIVE IT THE CASTEP AND QE OPTION OF LABC ! + + select case(igeom_output) + case(1) + call VASP_geom_write(UNIT,basis) + case(2) + call CASTEP_geom_write(UNIT,basis) + case(3) + call QE_geom_write(UNIT,basis) + case(4) + call stop_program("ERROR: Not yet set up for CRYSTAL") + return + case(5) + call XYZ_geom_write(UNIT,basis) + case(6) + call extXYZ_geom_write(UNIT,basis) + end select + + end subroutine geom_write +!############################################################################### + + +!############################################################################### + subroutine VASP_geom_read(UNIT, basis, length, iostat) + !! Read the structure in vasp poscar style format. + implicit none + + ! Arguments + integer, intent(in) :: UNIT + !! The unit number of the file to read from. + type(basis_type), intent(out) :: basis + !! The basis to read the geometry into. + integer, intent(in), optional :: length + !! Optional. The dimension of the basis atom positions. + integer, intent(out), optional :: iostat + !! Optional. The I/O status of the read. + + integer :: Reason + !! The I/O status of the read. + integer :: pos, count + !! Temporary integer variables. + real(real32) :: scal + !! The scaling factor of the lattice. + character(len=100) :: lspec + !! The species names and number of each atomic species. + character(len=1024) :: buffer + !! Temporary character variable. + integer :: i, j, k + !! Loop index. + integer :: length_ + !! The dimension of the basis atom positions. + integer :: iostat_ + !! The I/O status of the read. + + + length_ = 3 + iostat_ = 0 + !--------------------------------------------------------------------------- + ! determine dimension of basis (include translation dimension for symmetry?) + !--------------------------------------------------------------------------- + if(present(length)) length_ = length + + + !--------------------------------------------------------------------------- + ! read system name + !--------------------------------------------------------------------------- + read(UNIT,'(A)',iostat=Reason) basis%sysname + if(Reason.ne.0)then + write(0,'("ERROR: The file is not in POSCAR format.")') + write(0,*) "Expected system name, got: ",trim(basis%sysname) + iostat_ = 1 + if(present(iostat)) iostat = iostat_ + return + end if + read(UNIT,*) scal + + + !--------------------------------------------------------------------------- + ! read lattice + !--------------------------------------------------------------------------- + do i = 1, 3 + read(UNIT,*) (basis%lat(i,j),j=1,3) + end do + basis%lat=scal*basis%lat + + + !--------------------------------------------------------------------------- + ! read species names and number of each atomic species + !--------------------------------------------------------------------------- + read(UNIT,'(A)') lspec + basis%nspec = icount(lspec) + allocate(basis%spec(basis%nspec)) + if(verify(lspec,' 0123456789').ne.0) then + count=0;pos=1 + speccount: do + i=verify(lspec(pos:), ' ') + if (i.eq.0) exit speccount + count=count+1 + pos=i+pos-1 + i=scan(lspec(pos:), ' ') + if (i.eq.0) exit speccount + basis%spec(count)%name=lspec(pos:pos+i-1) + pos=i+pos-1 + end do speccount + + read(UNIT,*) (basis%spec(j)%num,j=1,basis%nspec) + else !only numbers + do count = 1, basis%nspec + write(basis%spec(count)%name,'(I0)') count + end do + read(lspec,*) (basis%spec(j)%num,j=1,basis%nspec) + end if + + + !--------------------------------------------------------------------------- + ! determines whether input basis is in direct or cartesian coordinates + !--------------------------------------------------------------------------- + basis%lcart=.false. + read(UNIT,'(A)') buffer + buffer = to_lower(buffer) + if(verify(trim(buffer),'direct').eq.0) basis%lcart=.false. + if(verify(trim(buffer),'cartesian').eq.0) basis%lcart=.true. + + + !--------------------------------------------------------------------------- + ! read basis + !--------------------------------------------------------------------------- + do i = 1, basis%nspec + allocate(basis%spec(i)%atom(basis%spec(i)%num,length_)) + basis%spec(i)%atom(:,:)=0._real32 + do j = 1, basis%spec(i)%num + read(UNIT,*) (basis%spec(i)%atom(j,k),k=1,3) + end do + end do + + + !--------------------------------------------------------------------------- + ! convert basis if in cartesian coordinates + !--------------------------------------------------------------------------- + if(basis%lcart) call basis%convert() + + + !--------------------------------------------------------------------------- + ! normalise basis to between 0 and 1 in direct coordinates + !--------------------------------------------------------------------------- + do i = 1, basis%nspec + do j = 1, basis%spec(i)%num + do k = 1, 3 + basis%spec(i)%atom(j,k)=& + basis%spec(i)%atom(j,k)-floor(basis%spec(i)%atom(j,k)) + end do + end do + end do + basis%natom=sum(basis%spec(:)%num) + + if(present(iostat)) iostat = iostat_ + + end subroutine VASP_geom_read +!############################################################################### + + +!############################################################################### + subroutine VASP_geom_write(UNIT, basis) + !! Write the structure in vasp poscar style format. + implicit none + + ! Arguments + integer, intent(in) :: UNIT + !! The unit number of the file to write to. + class(basis_type), intent(in) :: basis + !! The basis to write the geometry from. + + ! Local variables + integer :: i,j + !! Loop index. + character(100) :: fmt + !! Format string. + character(10) :: string + !! String to determine whether to write in direct or cartesian coordinates. + + + if(basis%lcart)then + string = "Cartesian" + else + string="Direct" + end if + + write(UNIT,'(A)') trim(adjustl(basis%sysname)) + write(UNIT,'(F15.9)') 1._real32 + do i = 1, 3 + write(UNIT,'(3(F15.9))') basis%lat(i,:) + end do + write(fmt,'("(",I0,"(A,1X))")') basis%nspec + write(UNIT,trim(adjustl(fmt))) (adjustl(basis%spec(j)%name),j=1,basis%nspec) + write(fmt,'("(",I0,"(I0,5X))")') basis%nspec + write(UNIT,trim(adjustl(fmt))) (basis%spec(j)%num,j=1,basis%nspec) + write(UNIT,'(A)') trim(adjustl(string)) + do i = 1, basis%nspec + do j = 1, basis%spec(i)%num + write(UNIT,'(3(F15.9))') basis%spec(i)%atom(j,1:3) + end do + end do + + end subroutine VASP_geom_write +!############################################################################### + + +!############################################################################### + subroutine QE_geom_read(UNIT,basis,length) + !! Read the structure in Quantum Espresso style format. + implicit none + + ! Arguments + integer, intent(in) :: UNIT + !! The unit number of the file to read from. + type(basis_type), intent(out) :: basis + !! The basis to read the geometry into. + integer, intent(in), optional :: length + !! Optional. The dimension of the basis atom positions. + + ! Local variables + integer :: Reason + !! The I/O status of the read. + integer :: i, j, k, iline + !! Loop index. + integer :: length_ = 3 + !! The dimension of the basis atom positions. + integer, dimension(1000) :: tmp_natom + !! Temporary array to store the number of atoms of each species. + real(real32), dimension(3) :: tmpvec + !! Temporary array to store the atomic positions. + character(len=3) :: ctmp + !! Temporary character variable. + character(256) :: stop_msg + !! Error message. + character(len=3), dimension(1000) :: tmp_spec + !! Temporary array to store the species names. + character(len=1024) :: buffer, buffer2 + !! Temporary character variables. + + + !--------------------------------------------------------------------------- + ! determine dimension of basis (include translation dimension for symmetry?) + !--------------------------------------------------------------------------- + if(present(length)) length_ = length + basis%lcart = .false. + basis%sysname = "Converted_from_geom_file" + + + !--------------------------------------------------------------------------- + ! read lattice + !--------------------------------------------------------------------------- + rewind UNIT + cellparam: do + read(UNIT,'(A)',iostat=Reason) buffer + if(Reason.ne.0)then + call stop_program( & + "An issue with the QE input file format has been encountered." & + ) + return + end if + if(index(trim(buffer),"ibrav").ne.0)then + write(stop_msg,*) & + "Internal error in QE_geom_read" // & + achar(13) // achar(10) // & + " Subroutine not yet set up to read IBRAV lattices" + call stop_program(stop_msg) + return + end if + if(verify("CELL_PARAMETERS",buffer).eq.0) then + exit cellparam + end if + end do cellparam + do i = 1, 3 + read(UNIT,*) (basis%lat(i,j),j=1,3) + end do + + + !--------------------------------------------------------------------------- + ! determines whether input basis is in direct or cartesian coordinates + !--------------------------------------------------------------------------- + iline=0 + rewind UNIT + basfind: do + read(UNIT,'(A)',iostat=Reason) buffer + iline=iline+1 + if(verify("ATOMIC_POSITIONS",buffer).eq.0)then + backspace(UNIT) + read(UNIT,*) buffer,buffer2 + if(verify("crystal",buffer2).eq.0) basis%lcart = .false. + if(verify("angstrom",buffer2).eq.0) basis%lcart = .true. + exit basfind + end if + end do basfind + + + !--------------------------------------------------------------------------- + ! read basis + !--------------------------------------------------------------------------- + basis%natom = 0 + basis%nspec = 0 + tmp_natom = 1 + basread: do + read(UNIT,'(A)',iostat=Reason) buffer + read(buffer,*) ctmp + if(Reason.ne.0) exit + if(trim(ctmp).eq.'') exit + if(verify(buffer,' 0123456789').eq.0) exit + basis%natom = basis%natom + 1 + if(.not.any(tmp_spec(1:basis%nspec).eq.ctmp))then + basis%nspec = basis%nspec + 1 + tmp_spec(basis%nspec) = ctmp + else + where(tmp_spec(1:basis%nspec).eq.ctmp) + tmp_natom(1:basis%nspec) = tmp_natom(1:basis%nspec) + 1 + end where + end if + end do basread + + allocate(basis%spec(basis%nspec)) + basis%spec(1:basis%nspec)%name = tmp_spec(1:basis%nspec) + do i = 1, basis%nspec + basis%spec(i)%num = 0 + allocate(basis%spec(i)%atom(tmp_natom(i),length_)) + end do + + call jump(UNIT,iline) + basread2: do i = 1, basis%natom + read(UNIT,*,iostat=Reason) ctmp,tmpvec(1:3) + do j = 1, basis%nspec + if(basis%spec(j)%name.eq.ctmp)then + basis%spec(j)%num = basis%spec(j)%num + 1 + basis%spec(j)%atom(basis%spec(j)%num,1:3) = tmpvec(1:3) + exit + end if + end do + end do basread2 + + + !--------------------------------------------------------------------------- + ! convert basis if in cartesian coordinates + !--------------------------------------------------------------------------- + if(basis%lcart) call basis%convert() + + + !--------------------------------------------------------------------------- + ! normalise basis to between 0 and 1 in direct coordinates + !--------------------------------------------------------------------------- + do i = 1, basis%nspec + do j = 1, basis%spec(i)%num + do k = 1, 3 + basis%spec(i)%atom(j,k) = & + basis%spec(i)%atom(j,k) - floor( basis%spec(i)%atom(j,k) ) + end do + end do + end do + basis%natom=sum(basis%spec(:)%num) + + end subroutine QE_geom_read +!############################################################################### + + +!############################################################################### + subroutine QE_geom_write(UNIT, basis, cartesian) + !! Write the structure in Quantum Espresso style format. + implicit none + + ! Arguments + integer, intent(in) :: UNIT + !! The unit number of the file to write to. + class(basis_type), intent(in) :: basis + !! The basis to write the geometry from. + logical, intent(in), optional :: cartesian + !! Optional. Whether to write the basis in cartesian coordinates. + + ! Local variables + integer :: i,j + !! Loop index. + character(10) :: string + !! String to determine whether to write in crystal or angstrom coordinates. + + + string="crystal" + if(present(cartesian))then + if(cartesian) string="angstrom" + end if + + + write(UNIT,'("CELL_PARAMETERS angstrom")') + do i = 1, 3 + write(UNIT,'(3(F15.9))') basis%lat(i,:) + end do + write(UNIT,'("ATOMIC_SPECIES")') + do i = 1, basis%nspec + write(UNIT,'(A)') trim(adjustl(basis%spec(i)%name)) + end do + write(UNIT,'("ATOMIC_POSITIONS",1X,A)') trim(adjustl(string)) + do i = 1, basis%nspec + do j = 1, basis%spec(i)%num + write(UNIT,'(A5,1X,3(F15.9))') & + basis%spec(i)%name,basis%spec(i)%atom(j,1:3) + end do + end do + + end subroutine QE_geom_write +!############################################################################### + + +!############################################################################### + subroutine CASTEP_geom_read(UNIT, basis, length) + !! Read the structure in CASTEP style format. + implicit none + + ! Arguments + integer, intent(in) :: UNIT + !! The unit number of the file to read from. + type(basis_type), intent(out) :: basis + !! The basis to read the geometry into. + integer, intent(in), optional :: length + !! Optional. The dimension of the basis atom positions. + + ! Local variables + integer :: Reason + !! The I/O status of the read. + integer :: i, j, k, iline + !! Loop index. + integer :: length_ = 3 + !! The dimension of the basis atom positions. + integer :: itmp1 + !! Temporary integer variable. + character(len=3) :: ctmp + !! Temporary character variable. + character(len=20) :: units + !! Units of the lattice vectors. + character(len=200) :: buffer, store + !! Temporary character variables. + logical :: labc + !! Logical variable to determine whether the lattice is in abc or + !! cartesian coordinates. + integer, dimension(1000) :: tmp_natom + !! Temporary array to store the number of atoms of each species. + real(real32), dimension(3) :: abc, angle, dvtmp1 + !! Temporary arrays to store the lattice vectors. + character(len=3), dimension(1000) :: tmp_spec + !! Temporary array to store the species names. + + + !--------------------------------------------------------------------------- + ! determine dimension of basis (include translation dimension for symmetry?) + !--------------------------------------------------------------------------- + if(present(length)) length_ = length + + + !--------------------------------------------------------------------------- + ! reading loop of file + !--------------------------------------------------------------------------- + tmp_spec = "" + tmp_natom = 0 + iline = 0 + labc = .true. + basis%sysname = "from CASTEP" + rewind(UNIT) + readloop: do + iline=iline+1 + read(UNIT,'(A)',iostat=Reason) buffer + if(Reason.ne.0) exit + buffer=to_upper(buffer) + if(scan(trim(adjustl(buffer)),'%').ne.1) cycle readloop + if(index(trim(adjustl(buffer)),'%END').eq.1) cycle readloop + read(buffer,*) store, buffer + if(trim(buffer).eq.'') cycle readloop + !------------------------------------------------------------------------ + ! read lattice + !------------------------------------------------------------------------ + lattice_if: if(index(trim(buffer),"LATTICE").eq.1)then + if(index(trim(buffer),"ABC").ne.0) labc = .true. + if(index(trim(buffer),"CART").ne.0) labc = .false. + store = "" + itmp1 = 0 + lattice_loop: do + itmp1 = itmp1 + 1 + read(UNIT,'(A)',iostat=Reason) buffer + if(Reason.ne.0) exit lattice_loop + if(scan(trim(adjustl(buffer)),'%').eq.1) exit lattice_loop + if(itmp1.eq.5)then + call stop_program( & + "Too many lines in LATTICE block of structure file" & + ) + return + end if + store=trim(store)//" "//trim(buffer) + end do lattice_loop + iline=iline+itmp1 + + if(labc)then + read(store,*) units,(abc(i),i=1,3), (angle(j),j=1,3) + basis%lat = convert_abc_to_lat(abc,angle,.false.) + else + read(store,*) units,(basis%lat(i,:),i=1,3) + end if + cycle readloop + end if lattice_if + + !------------------------------------------------------------------------ + ! read basis + !------------------------------------------------------------------------ + basis_if: if(index(trim(buffer),"POSITIONS").eq.1) then + if(index(trim(buffer),"ABS").ne.0) basis%lcart=.true. + if(index(trim(buffer),"FRAC").ne.0) basis%lcart=.false. + itmp1 = 0 + basis_loop1: do + read(UNIT,'(A)',iostat=Reason) buffer + if(Reason.ne.0) exit basis_loop1 + if(scan(trim(adjustl(buffer)),'%').eq.1) exit basis_loop1 + read(buffer,*) ctmp + if(trim(ctmp).eq.'') exit + if(verify(buffer,' 0123456789').eq.0) exit + basis%natom = basis%natom + 1 + if(.not.any(tmp_spec(1:basis%nspec).eq.ctmp))then + basis%nspec = basis%nspec+1 + tmp_natom(basis%nspec) = 1 + tmp_spec(basis%nspec) = ctmp + else + where(tmp_spec(1:basis%nspec).eq.ctmp) + tmp_natom(1:basis%nspec) = tmp_natom(1:basis%nspec) + 1 + end where + end if + end do basis_loop1 + + allocate(basis%spec(basis%nspec)) + basis%spec(1:basis%nspec)%name = tmp_spec(1:basis%nspec) + do i = 1, basis%nspec + basis%spec(i)%num = 0 + allocate(basis%spec(i)%atom(tmp_natom(i),length_)) + end do + + call jump(UNIT,iline) + basis_loop2: do i = 1, basis%natom + read(UNIT,'(A)',iostat=Reason) buffer + if(Reason.ne.0)then + call stop_program("Internal error in assigning the basis") + return + end if + read(buffer,*) ctmp,dvtmp1(1:3) + species_loop: do j = 1, basis%nspec + if(basis%spec(j)%name.eq.ctmp)then + basis%spec(j)%num = basis%spec(j)%num + 1 + basis%spec(j)%atom(basis%spec(j)%num,1:3) = dvtmp1(1:3) + exit species_loop + end if + end do species_loop + end do basis_loop2 + + end if basis_if + end do readloop + + + !--------------------------------------------------------------------------- + ! convert basis if in cartesian coordinates + !--------------------------------------------------------------------------- + if(basis%lcart) call basis%convert() + + + !--------------------------------------------------------------------------- + ! normalise basis to between 0 and 1 in direct coordinates + !--------------------------------------------------------------------------- + do i = 1, basis%nspec + do j = 1, basis%spec(i)%num + do k = 1, 3 + basis%spec(i)%atom(j,k) = & + basis%spec(i)%atom(j,k) - floor( basis%spec(i)%atom(j,k) ) + end do + end do + end do + basis%natom=sum(basis%spec(:)%num) + + end subroutine CASTEP_geom_read +!############################################################################### + + +!############################################################################### + subroutine CASTEP_geom_write(UNIT, basis, labc, cartesian) + !! Write the structure in CASTEP style format. + implicit none + + ! Arguments + integer :: UNIT + !! The unit number of the file to write to. + class(basis_type), intent(in) :: basis + !! The basis to write the geometry from. + logical, intent(in), optional :: labc + !! Optional. Boolean whether to write the lattice in abc format. + logical, intent(in), optional :: cartesian + !! Optional. Boolean whether to write basis in cartesian coordinates. + + ! Local variables + integer :: i, j + !! Loop index. + real(real32), dimension(2,3) :: abc_angle + !! Temporary arrays to store the lattice vectors. + character(4) :: string_lat, string_bas + !! Strings specifying lattice and basis format + character(len=256) :: stop_msg + !! Error message. + + + string_lat="CART" + if(present(labc))then + if(labc) string_lat="ABC" + end if + + string_bas="FRAC" + if(present(cartesian))then + if(cartesian)then + string_bas="ABS" + write(stop_msg,*) & + "Internal error in CASTEP_geom_write" // & + achar(13) // achar(10) // & + " Subroutine not yet set up to output cartesian coordinates" + call stop_program(stop_msg) + return + end if + end if + + write(UNIT,'("%block LATTICE_",A)') trim(string_lat) + write(UNIT,'("ang")') + if(present(labc))then + if(labc)then + abc_angle = convert_lat_to_abc(basis%lat) + write(UNIT,'(3(F15.9))') abc_angle(1,:) + write(UNIT,'(3(F15.9))') abc_angle(2,:) + goto 10 + end if + end if + do i = 1, 3 + write(UNIT,'(3(F15.9))') basis%lat(i,:) + end do + +10 write(UNIT,'("%endblock LATTICE_",A)') trim(string_lat) + + write(UNIT,*) + write(UNIT,'("%block POSITIONS_",A)') trim(string_bas) + do i = 1, basis%nspec + do j = 1, basis%spec(i)%num + write(UNIT,'(A5,1X,3(F15.9))') & + basis%spec(i)%name,basis%spec(i)%atom(j,1:3) + end do + end do + write(UNIT,'("%endblock POSITIONS_",A)') trim(string_bas) + + end subroutine CASTEP_geom_write +!############################################################################### + + +!############################################################################### + subroutine XYZ_geom_read(UNIT, basis, length, iostat) + !! Read the structure in xyz style format. + implicit none + + ! Arguments + integer, intent(in) :: UNIT + !! The unit number of the file to read from. + type(basis_type), intent(out) :: basis + !! The basis to read the geometry into. + integer, intent(in), optional :: length + !! Optional. The dimension of the basis atom positions. + integer, intent(out), optional :: iostat + !! Optional. The I/O status of the read. + + ! Local variables + integer :: Reason + !! The I/O status of the read. + integer :: i, j + !! Loop index. + integer, allocatable, dimension(:) :: tmp_num + !! Temporary array to store the number of atoms of each species. + real(real32), dimension(3) :: vec + !! Temporary array to store the atomic positions. + real(real32), allocatable, dimension(:,:,:) :: tmp_bas + !! Temporary array to store the atomic positions. + character(len=3) :: ctmp + !! Temporary character variable. + character(len=3), allocatable, dimension(:) :: tmp_spec + !! Temporary array to store the species names. + integer :: length_ + !! The dimension of the basis atom positions. + integer :: iostat_ + !! The I/O status of the read. + + + length_ = 3 + iostat_ = 0 + if(present(length)) length_ = length + + + read(UNIT,*,iostat=Reason) basis%natom + if(Reason.ne.0)then + write(0,'("ERROR: The file is not in xyz format.")') + iostat_ = 1 + if(present(iostat)) iostat = iostat_ + return + end if + read(UNIT,'(A)',iostat=Reason) basis%sysname + + + !--------------------------------------------------------------------------- + ! read basis + !--------------------------------------------------------------------------- + allocate(tmp_spec(basis%natom)) + allocate(tmp_num(basis%natom)) + allocate(tmp_bas(basis%natom,basis%natom,length_)) + tmp_num(:) = 0 + tmp_spec = "" + tmp_bas = 0 + basis%nspec = 0 + do i = 1, basis%natom + read(UNIT,*,iostat=Reason) ctmp,vec(1:3) + if(.not.any(tmp_spec(1:basis%nspec).eq.ctmp))then + basis%nspec = basis%nspec + 1 + tmp_spec(basis%nspec) = ctmp + tmp_bas(basis%nspec,1,1:3) = vec(1:3) + tmp_num(basis%nspec) = 1 + else + checkspec: do j = 1, basis%nspec + if(tmp_spec(j).eq.ctmp)then + tmp_num(j) = tmp_num(j)+1 + tmp_bas(j,tmp_num(j),1:3) = vec(1:3) + exit checkspec + end if + end do checkspec + end if + end do + + + !--------------------------------------------------------------------------- + ! move basis from temporary basis to main basis. + ! done to allow for correct allocation of number of and per species + !--------------------------------------------------------------------------- + allocate(basis%spec(basis%nspec)) + do i = 1, basis%nspec + basis%spec(i)%name = tmp_spec(i) + basis%spec(i)%num = tmp_num(i) + allocate(basis%spec(i)%atom(tmp_num(i),length_)) + basis%spec(i)%atom(:,:) = 0 + basis%spec(i)%atom(1:tmp_num(i),1:3) = tmp_bas(i,1:tmp_num(i),1:3) + end do + + if(present(iostat)) iostat = iostat_ + + end subroutine XYZ_geom_read +!############################################################################### + + +!############################################################################### + subroutine XYZ_geom_write(UNIT,basis) + !! Write the structure in xyz style format. + implicit none + + ! Arguments + integer, intent(in) :: UNIT + !! The unit number of the file to write to. + class(basis_type), intent(in) :: basis + !! The basis to write the geometry from. + + ! Local variables + integer :: i, j + !! Loop index. + + + write(UNIT,'("I0")') basis%natom + write(UNIT,'("A")') basis%sysname + do i = 1, basis%nspec + do j = 1, basis%spec(i)%num + write(UNIT,'(A5,1X,3(F15.9))') & + basis%spec(i)%name,basis%spec(i)%atom(j,1:3) + end do + end do + + end subroutine XYZ_geom_write +!############################################################################### + + +!############################################################################### + subroutine extXYZ_geom_read(UNIT, basis, length, iostat) + !! Read the structure in extended xyz style format. + implicit none + + ! Arguments + integer, intent(in) :: UNIT + !! The unit number of the file to read from. + type(basis_type), intent(out) :: basis + !! The basis to read the geometry into. + integer, intent(in), optional :: length + !! Optional. The dimension of the basis atom positions. + integer, intent(out), optional :: iostat + !! Optional. The I/O status of the read. + + ! Local variables + integer :: Reason + !! The I/O status of the read. + integer :: i, j + !! Loop index. + integer :: index1, index2 + !! Index variables. + integer, allocatable, dimension(:) :: tmp_num + !! Temporary array to store the number of atoms of each species. + real(real32), dimension(3) :: vec + !! Temporary array to store the atomic positions. + real(real32), allocatable, dimension(:,:,:) :: tmp_bas + !! Temporary array to store the atomic positions. + character(len=3) :: ctmp + !! Temporary character variable. + character(len=3), allocatable, dimension(:) :: tmp_spec + !! Temporary array to store the species names. + character(len=1024) :: buffer + !! Temporary character variable. + integer :: length_ = 3 + !! The dimension of the basis atom positions. + integer :: iostat_ = 0 + !! The I/O status of the read. + + + basis%lcart=.true. + if(present(length)) length_ = length + + + !--------------------------------------------------------------------------- + ! read system information + !--------------------------------------------------------------------------- + read(UNIT,*,iostat=Reason) basis%natom + if(Reason.ne.0)then + write(0,'("ERROR: The file is not in xyz format.")') + iostat_ = 1 + if(present(iostat)) iostat = iostat_ + return + end if + read(UNIT,'(A)',iostat=Reason) buffer + if(Reason.ne.0)then + write(0,'("ERROR: The file is not in xyz format.")') + iostat_ = 1 + if(present(iostat)) iostat = iostat_ + return + end if + index1 = index(buffer,'Lattice="') + 9 + index2 = index(buffer(index1:),'"') + index1 - 2 + read(buffer(index1:index2),*) ( ( basis%lat(i,j), j = 1, 3), i = 1, 3) + + index1 = index(buffer,'free_energy=') + 12 + read(buffer(index1:),*) basis%energy + + + !--------------------------------------------------------------------------- + ! read basis + !--------------------------------------------------------------------------- + allocate(tmp_spec(basis%natom)) + allocate(tmp_num(basis%natom)) + allocate(tmp_bas(basis%natom,basis%natom,length_)) + tmp_num(:) = 0 + tmp_spec = "" + tmp_bas = 0 + basis%nspec = 0 + do i = 1, basis%natom + read(UNIT,*,iostat=Reason) ctmp, vec(1:3) + if(.not.any(tmp_spec(1:basis%nspec).eq.ctmp))then + basis%nspec=basis%nspec+1 + tmp_spec(basis%nspec) = trim(adjustl(ctmp)) + tmp_bas(basis%nspec,1,1:3) = vec(1:3) + tmp_num(basis%nspec) = 1 + else + checkspec: do j = 1, basis%nspec + if(tmp_spec(j).eq.ctmp)then + tmp_num(j) = tmp_num(j) + 1 + tmp_bas(j,tmp_num(j),1:3) = vec(1:3) + exit checkspec + end if + end do checkspec + end if + end do + + + !--------------------------------------------------------------------------- + ! move basis from temporary basis to main basis. + ! done to allow for correct allocation of number of and per species + !--------------------------------------------------------------------------- + allocate(basis%spec(basis%nspec)) + basis%sysname = "" + do i = 1, basis%nspec + basis%spec(i)%name = tmp_spec(i) + basis%spec(i)%num = tmp_num(i) + allocate(basis%spec(i)%atom(tmp_num(i),length_)) + basis%spec(i)%atom(:,:) = 0 + basis%spec(i)%atom(1:tmp_num(i),1:3) = tmp_bas(i,1:tmp_num(i),1:3) + write(buffer,'(I0,A)') basis%spec(i)%num,trim(basis%spec(i)%name) + basis%sysname = basis%sysname//trim(buffer) + if(i.lt.basis%nspec) basis%sysname = trim(adjustl(basis%sysname))//"_" + end do + + if(present(iostat)) iostat = iostat_ + + end subroutine extXYZ_geom_read +!############################################################################### + + +!############################################################################### + subroutine extXYZ_geom_write(UNIT, basis) + !! Write the structure in extended xyz style format. + implicit none + + ! Arguments + integer, intent(in) :: UNIT + !! The unit number of the file to write to. + class(basis_type), intent(in) :: basis + !! The basis to write the geometry from. + + ! Local variables + integer :: i, j + !! Loop index. + + + write(UNIT,'(I0)') basis%natom + write(UNIT,'(A,8(F0.8,1X),F0.8,A)', advance="no") & + 'Lattice="',((basis%lat(i,j),j=1,3),i=1,3),'"' + write(UNIT,'(A,F0.8)', advance="no") ' free_energy=',basis%energy + write(UNIT,'(A)', advance="no") ' pbc="T T T"' + if(basis%lcart)then + do i = 1, basis%nspec + do j = 1, basis%spec(i)%num + write(UNIT,'(A8,3(1X, F16.8))') & + basis%spec(i)%name,basis%spec(i)%atom(j,1:3) + end do + end do + else + do i = 1, basis%nspec + do j = 1, basis%spec(i)%num + write(UNIT,'(A8,3(1X, F16.8))') basis%spec(i)%name, & + matmul(basis%spec(i)%atom(j,1:3),basis%lat) + end do + end do + end if + + end subroutine extXYZ_geom_write +!############################################################################### + + +!############################################################################### + subroutine convert(this) + !! Convert the basis between direct and cartesian coordinates. + implicit none + + ! Arguments + class(basis_type), intent(inout) :: this + !! Parent. The basis to convert. + + ! Local variables + integer :: is, ia + !! Loop index. + real(real32), dimension(3,3) :: lattice + !! The reciprocal lattice vectors. + + + if(this%lcart)then + lattice = inverse_3x3( this%lat ) + else + lattice = this%lat + end if + + this%lcart = .not.this%lcart + do is = 1, this%nspec + do ia = 1, this%spec(is)%num + this%spec(is)%atom(ia,1:3) = & + matmul( this%spec(is)%atom(ia,1:3), lattice ) + end do + end do + + end subroutine convert +!############################################################################### + + +!############################################################################### + subroutine change_lattice(this, lattice) + !! Change the lattice of the basis. + !! + !! This transforms the basis to a new lattice. + implicit none + + ! Arguments + class(basis_type), intent(inout) :: this + !! Parent. The basis to transform. + real(real32), dimension(3,3), intent(in) :: lattice + !! The new lattice. + + ! Local variables + ! integer :: is, ia + ! !! Loop index. + ! real(real32), dimension(3,3) :: transform + ! !! The transformation matrix. + logical :: lcart + !! Logical variable to determine whether the basis is in cartesian coordinates. + + + ! transform = matmul(inverse_3x3(lattice),this%lat) + lcart = this%lcart + if(.not.lcart) call this%convert() + ! do is = 1, this%nspec + ! do ia = 1, this%spec(is)%num + ! this%spec(is)%atom(ia,1:3) = & + ! matmul(transform, this%spec(is)%atom(ia,1:3)) + ! end do + ! end do + this%lat = lattice + if(.not.lcart) call this%convert() + + end subroutine change_lattice +!############################################################################### + + +!############################################################################### + subroutine normalise( & + this, & + ceil_val, & + floor_coords, round_coords, & + zero_round & + ) + !! Normalise the basis to between 0 and 1. + implicit none + + ! Arguments + class(basis_type), intent(inout) :: this + !! Parent. The basis to normalise. + real(real32), intent(in), optional :: ceil_val + !! Optional. The ceiling value for normalisation. + logical, intent(in), optional :: floor_coords + !! Optional. Whether to floor the coordinates. + logical, intent(in), optional :: round_coords + !! Optional. Whether to round the coordinates. + real(real32), intent(in), optional :: zero_round + !! Optional. The value to set coordinates to if they are less than tol. + + ! Local variables + integer :: is, ia, j + !! Loop index. + real(real32) :: ceil_val_, floor_val, tol + !! The ceiling value, floor value, and tolerance. + logical :: floor_coords_, round_coords_ + !! Boolean whether to floor and round the coordinates. + + + ceil_val_ = 1._real32 + floor_coords_ = .false. + if(present(ceil_val)) ceil_val_ = ceil_val + if(present(floor_coords)) floor_coords_ = floor_coords + floor_val = ceil_val_ - 1._real32 + tol = 1.E-8_real32 + round_coords_ = .false. + if(present(round_coords)) round_coords_ = round_coords + + do is=1,this%nspec + do ia=1,this%spec(is)%num + do j=1,3 + if(floor_coords_)then + this%spec(is)%atom(ia,j) = this%spec(is)%atom(ia,j) - & + floor(this%spec(is)%atom(ia,j) - floor_val) + else + this%spec(is)%atom(ia,j) = this%spec(is)%atom(ia,j) - & + ceiling(this%spec(is)%atom(ia,j)-ceil_val_) + end if + if(round_coords_)then + if(abs(this%spec(is)%atom(ia,j)-ceil_val_).lt.tol.or.& + abs(this%spec(is)%atom(ia,j)).lt.tol) & + this%spec(is)%atom(ia,j) = floor_val + end if + if(present(zero_round))then + if(abs(this%spec(is)%atom(ia,j)).lt.tol) & + this%spec(is)%atom(ia,j) = zero_round + end if + end do + end do + end do + + end subroutine normalise +!############################################################################### + + +!############################################################################### + function convert_abc_to_lat(abc,angle,radians) result(lattice) + !! Convert the lattice from abc and αβγ to lattice matrix. + implicit none + + ! Arguments + real(real32), dimension(3), intent(in) :: abc, angle + !! lattice constants + logical, intent(in), optional :: radians + !! Optional. Boolean whether angles are in radians. + real(real32), dimension(3,3) :: lattice + !! The lattice matrix. + + ! Local variables + real(real32), dimension(3) :: in_angle + !! The lattice angles in radians. + + + + in_angle = angle + if(present(radians))then + if(.not.radians) in_angle = angle*pi/180._real32 + end if + + lattice=0._real32 + + lattice(1,1)=abc(1) + lattice(2,:2)=(/abc(2)*cos(in_angle(3)),abc(2)*sin(in_angle(3))/) + + lattice(3,1) = abc(3)*cos(in_angle(2)) + lattice(3,2) = abc(3)*(cos(in_angle(1)) - cos(in_angle(2))*& + cos(in_angle(3)))/sin(in_angle(3)) + lattice(3,3) = sqrt(abc(3)**2._real32 - & + lattice(3,1)**2._real32 - & + lattice(3,2)**2._real32) + + end function convert_abc_to_lat +!############################################################################### + + +!############################################################################### + function convert_lat_to_abc(lattice, radians) result(abc_angle) + !! Convert the lattice from lattice matrix to abc and αβγ. + implicit none + + ! Arguments + real(real32), dimension(3,3), intent(in) :: lattice + !! The lattice matrix. + logical, intent(in), optional :: radians + !! Optional. Boolean whether to return angles in radians. + real(real32), dimension(2,3) :: abc_angle + !! The lattice constants and angles. + + ! Local variables + integer :: i + !! Loop index. + + + do i = 1, 3 + abc_angle(1,i)=modu(lattice(i,:)) + end do + do i = 1, 3 + end do + abc_angle(2,1)=acos(dot_product(lattice(2,:),lattice(3,:))/& + (abc_angle(1,2)*abc_angle(1,3))) + abc_angle(2,3)=acos(dot_product(lattice(1,:),lattice(3,:))/& + (abc_angle(1,1)*abc_angle(1,3))) + abc_angle(2,3)=acos(dot_product(lattice(1,:),lattice(2,:))/& + (abc_angle(1,1)*abc_angle(1,2))) + + if(present(radians))then + if(.not.radians) abc_angle(2,:)=abc_angle(2,:)*180._real32/pi + end if + + end function convert_lat_to_abc +!############################################################################### + + +!############################################################################### + function get_lattice_constants(this, radians) result(output) + !! Convert the lattice from lattice matrix to abc and αβγ. + implicit none + + ! Arguments + class(basis_type), intent(in) :: this + !! Parent. The basis. + logical, intent(in), optional :: radians + !! Optional. Boolean whether to return angles in radians. + real(real32), dimension(2,3) :: output + !! The lattice constants and angles. + + ! Local variables + logical :: radians_ + !! Boolean whether to return angles in radians. + + + radians_ = .true. + if(present(radians)) radians_ = radians + + output = convert_lat_to_abc(this%lat, radians_) + + end function get_lattice_constants +!############################################################################### + + +!############################################################################### + subroutine copy(this, basis, length) + !! Copy the basis. + implicit none + + ! Arguments + class(basis_type), intent(inout) :: this + !! Parent. The basis to copy into. + class(basis_type), intent(in) :: basis + !! The basis to copy from. + integer, intent(in), optional :: length + !! The dimension of the basis atom positions. + + + ! Local variables + integer :: i + !! Loop index. + integer :: length_, length_input + !! The dimension of the basis atom positions. + + + !--------------------------------------------------------------------------- + ! determines whether user wants output basis extra translational dimension + !--------------------------------------------------------------------------- + if(.not.allocated(basis%spec))then + call stop_program("Basis not allocated") + return + end if + length_input = size(basis%spec(lbound(basis%spec,1))%atom,dim=2) + if(present(length))then + length_ = length + else + length_ = length_input + end if + + + !--------------------------------------------------------------------------- + ! if already allocated, deallocates output basis + !--------------------------------------------------------------------------- + if(allocated(this%spec))then + do i = 1, this%nspec + if(allocated(this%spec(i)%atom)) deallocate(this%spec(i)%atom) + end do + deallocate(this%spec) + end if + + + !--------------------------------------------------------------------------- + ! allocates output basis and clones data from input basis to output basis + !--------------------------------------------------------------------------- + allocate(this%spec(basis%nspec)) + do i = 1, basis%nspec + allocate(this%spec(i)%atom(& + basis%spec(i)%num,length_)) + + this%spec(i)%atom(:,:3) = basis%spec(i)%atom(:,:3) + if(length_input.eq.length_)then + this%spec(i)%atom(:,:length_) = basis%spec(i)%atom(:,:length_) + elseif(length_input.gt.length_)then + this%spec(i)%atom(:,:3) = basis%spec(i)%atom(:,:3) + elseif(length_input.lt.length_)then + this%spec(i)%atom(:,:3) = basis%spec(i)%atom(:,:3) + this%spec(i)%atom(:,4) = 1._real32 + end if + this%spec(i)%num = basis%spec(i)%num + this%spec(i)%name = strip_null(basis%spec(i)%name) + + this%spec(i)%mass = basis%spec(i)%mass + this%spec(i)%charge = basis%spec(i)%charge + this%spec(i)%radius = basis%spec(i)%radius + end do + this%nspec = basis%nspec + this%natom = basis%natom + this%lcart = basis%lcart + this%sysname = basis%sysname + this%energy = basis%energy + this%lat = basis%lat + this%pbc = basis%pbc + + end subroutine copy +!############################################################################### + + +!############################################################################### + subroutine remove_atom(this, ispec, iatom) + !! Remove an atom from the basis. + implicit none + + ! Arguments + class(basis_type), intent(inout) :: this + !! Parent. The basis. + integer, intent(in) :: ispec, iatom + !! The species and atom to remove. + + ! Local variables + integer :: i + !! Loop index. + real(real32), dimension(:,:), allocatable :: atom + !! Temporary array to store the atomic positions. + + + !--------------------------------------------------------------------------- + ! remove atom from basis + !--------------------------------------------------------------------------- + do i = 1, this%nspec + if(i.eq.ispec)then + if(iatom.gt.this%spec(i)%num)then + call stop_program("Atom to remove does not exist") + return + end if + allocate(atom(this%spec(i)%num-1,size(this%spec(i)%atom,2))) + atom(1:iatom-1:1,:) = this%spec(i)%atom(1:iatom-1:1,:) + atom(iatom:this%spec(i)%num-1:1,:) = & + this%spec(i)%atom(iatom+1:this%spec(i)%num:1,:) + this%spec(i)%atom = atom + deallocate(atom) + this%spec(i)%num = this%spec(i)%num - 1 + this%natom = this%natom - 1 + if(this%spec(i)%num.eq.0)then + deallocate(this%spec(i)%atom) + if(this%nspec.eq.0)then + deallocate(this%spec) + this%lcart = .true. + this%sysname = "" + this%energy = 0._real32 + this%lat = 0._real32 + this%pbc = .true. + end if + end if + end if + end do + + end subroutine remove_atom +!############################################################################### + + +!############################################################################### + subroutine remove_atoms(this, atoms) + !! Remove atoms from the basis. + use artemis__misc, only: swap + implicit none + + ! Arguments + class(basis_type), intent(inout) :: this + !! Parent. The basis. + integer, dimension(:,:), intent(in) :: atoms + !! The atoms to remove (2, number of atoms to remove) + !! 1st value of 1st dimension is the species number + !! 2nd value of 1st dimension is the atom number + !! 2nd dimension is the number of atoms to remove + + ! Local variables + integer :: is, ia, i + !! Loop index. + integer :: n, m, start_idx, end_idx, loc + !! Index variables. + integer :: num_species + !! The number of species. + integer, dimension(:,:), allocatable :: atoms_ordered + !! The atoms to remove ordered by species and atom + + + !--------------------------------------------------------------------------- + ! reorder atoms to remove + !--------------------------------------------------------------------------- + allocate(atoms_ordered, source=atoms) + n = size(atoms_ordered, 1) + m = size(atoms_ordered, 2) + + do i = 1, m + loc = maxloc(atoms_ordered(1, i:n), dim=1) + i - 1 + if (loc .ne. i) then + call swap(atoms_ordered(1, i), atoms_ordered(1, loc)) + call swap(atoms_ordered(2, i), atoms_ordered(2, loc)) + end if + end do + num_species = this%nspec + do is = 1, num_species + start_idx = findloc(atoms_ordered(1, :), is, dim=1) + end_idx = findloc(atoms_ordered(1, :), is, dim=1, back=.true.) + if (start_idx .eq. 0) cycle + do ia = start_idx, end_idx, 1 + loc = maxloc( & + atoms_ordered(2, ia:end_idx), & + dim=1 & + ) + ia - 1 + if (loc .ne. ia) then + call swap(atoms_ordered(1, ia), atoms_ordered(1, loc)) + call swap(atoms_ordered(2, ia), atoms_ordered(2, loc)) + end if + end do + end do + + + !--------------------------------------------------------------------------- + ! remove atoms from basis + !--------------------------------------------------------------------------- + do i = 1, size(atoms_ordered, 2) + call this%remove_atom(atoms_ordered(1, i), atoms_ordered(2, i)) + end do + + do is = 1, this%nspec + if (this%spec(is)%num .eq. 0) then + this%spec = [ this%spec(1:is-1), this%spec(is+1:) ] + this%nspec = this%nspec - 1 + end if + end do + + end subroutine remove_atoms +!############################################################################### + + +!############################################################################### + subroutine get_element_properties(element, charge, mass, radius) + !! Set the mass and charge of the element + implicit none + + ! Arguments + character(len=3), intent(in) :: element + !! Element name. + real(real32), intent(out), optional :: charge + !! Charge of the element. + real(real32), intent(out), optional :: mass + !! Mass of the element. + real(real32), intent(out), optional :: radius + !! Radius of the element. + + ! Local variables + real(real32) :: mass_, charge_, radius_ + !! Mass, charge and radius of the element. + + select case(element) + case('H') + mass_ = 1.00784_real32 + charge_ = 1.0_real32 + radius_ = 0.31_real32 + case('He') + mass_ = 4.0026_real32 + charge_ = 2.0_real32 + radius_ = 0.28_real32 + case('Li') + mass_ = 6.94_real32 + charge_ = 3.0_real32 + radius_ = 1.28_real32 + case('Be') + mass_ = 9.0122_real32 + charge_ = 4.0_real32 + radius_ = 0.96_real32 + case('B') + mass_ = 10.81_real32 + charge_ = 5.0_real32 + radius_ = 0.84_real32 + case('C') + mass_ = 12.011_real32 + charge_ = 6.0_real32 + radius_ = 0.76_real32 + case('N') + mass_ = 14.007_real32 + charge_ = 7.0_real32 + radius_ = 0.71_real32 + case('O') + mass_ = 15.999_real32 + charge_ = 8.0_real32 + radius_ = 0.66_real32 + case('F') + mass_ = 18.998_real32 + charge_ = 9.0_real32 + radius_ = 0.57_real32 + case('Ne') + mass_ = 20.180_real32 + charge_ = 10.0_real32 + radius_ = 0.58_real32 + case('Na') + mass_ = 22.989_real32 + charge_ = 11.0_real32 + radius_ = 1.66_real32 + case('Mg') + mass_ = 24.305_real32 + charge_ = 12.0_real32 + radius_ = 1.41_real32 + case('Al') + mass_ = 26.982_real32 + charge_ = 13.0_real32 + radius_ = 1.21_real32 + case('Si') + mass_ = 28.085_real32 + charge_ = 14.0_real32 + radius_ = 1.11_real32 + case('P') + mass_ = 30.974_real32 + charge_ = 15.0_real32 + radius_ = 1.07_real32 + case('S') + mass_ = 32.06_real32 + charge_ = 16.0_real32 + radius_ = 1.05_real32 + case('Cl') + mass_ = 35.453_real32 + charge_ = 17.0_real32 + radius_ = 1.02_real32 + case('Ar') + mass_ = 39.948_real32 + charge_ = 18.0_real32 + radius_ = 1.06_real32 + case('K') + mass_ = 39.098_real32 + charge_ = 19.0_real32 + radius_ = 2.03_real32 + case('Ca') + mass_ = 40.078_real32 + charge_ = 20.0_real32 + radius_ = 1.74_real32 + case('Sc') + mass_ = 44.956_real32 + charge_ = 21.0_real32 + radius_ = 1.44_real32 + case('Ti') + mass_ = 47.867_real32 + charge_ = 22.0_real32 + radius_ = 1.32_real32 + case('V') + mass_ = 50.942_real32 + charge_ = 23.0_real32 + radius_ = 1.22_real32 + case('Cr') + mass_ = 51.996_real32 + charge_ = 24.0_real32 + radius_ = 1.18_real32 + case('Mn') + mass_ = 54.938_real32 + charge_ = 25.0_real32 + radius_ = 1.17_real32 + case('Fe') + mass_ = 55.845_real32 + charge_ = 26.0_real32 + radius_ = 1.17_real32 + case('Co') + mass_ = 58.933_real32 + charge_ = 27.0_real32 + radius_ = 1.16_real32 + case('Ni') + mass_ = 58.693_real32 + charge_ = 28.0_real32 + radius_ = 1.15_real32 + case('Cu') + mass_ = 63.546_real32 + charge_ = 29.0_real32 + radius_ = 1.17_real32 + case('Zn') + mass_ = 65.38_real32 + charge_ = 30.0_real32 + radius_ = 1.25_real32 + case('Ga') + mass_ = 69.723_real32 + charge_ = 31.0_real32 + radius_ = 1.26_real32 + case('Ge') + mass_ = 72.63_real32 + charge_ = 32.0_real32 + radius_ = 1.22_real32 + case('As') + mass_ = 74.922_real32 + charge_ = 33.0_real32 + radius_ = 1.19_real32 + case('Se') + mass_ = 78.971_real32 + charge_ = 34.0_real32 + radius_ = 1.16_real32 + case('Br') + mass_ = 79.904_real32 + charge_ = 35.0_real32 + radius_ = 1.14_real32 + case('Kr') + mass_ = 83.798_real32 + charge_ = 36.0_real32 + radius_ = 1.12_real32 + case('Rb') + mass_ = 85.468_real32 + charge_ = 37.0_real32 + radius_ = 2.16_real32 + case('Sr') + mass_ = 87.62_real32 + charge_ = 38.0_real32 + radius_ = 1.91_real32 + case('Y') + mass_ = 88.906_real32 + charge_ = 39.0_real32 + radius_ = 1.62_real32 + case('Zr') + mass_ = 91.224_real32 + charge_ = 40.0_real32 + radius_ = 1.45_real32 + case('Nb') + mass_ = 92.906_real32 + charge_ = 41.0_real32 + radius_ = 1.34_real32 + case('Mo') + mass_ = 95.95_real32 + charge_ = 42.0_real32 + radius_ = 1.3_real32 + case('Tc') + mass_ = 98.0_real32 + charge_ = 43.0_real32 + radius_ = 1.27_real32 + case('Ru') + mass_ = 101.07_real32 + charge_ = 44.0_real32 + radius_ = 1.25_real32 + case('Rh') + mass_ = 102.91_real32 + charge_ = 45.0_real32 + radius_ = 1.25_real32 + case('Pd') + mass_ = 106.42_real32 + charge_ = 46.0_real32 + radius_ = 1.28_real32 + case('Ag') + mass_ = 107.87_real32 + charge_ = 47.0_real32 + radius_ = 1.34_real32 + case('Cd') + mass_ = 112.41_real32 + charge_ = 48.0_real32 + radius_ = 1.48_real32 + case('In') + mass_ = 114.82_real32 + charge_ = 49.0_real32 + radius_ = 1.44_real32 + case('Sn') + mass_ = 118.71_real32 + charge_ = 50.0_real32 + radius_ = 1.41_real32 + case('Sb') + mass_ = 121.76_real32 + charge_ = 51.0_real32 + radius_ = 1.38_real32 + case('Te') + mass_ = 127.6_real32 + charge_ = 52.0_real32 + radius_ = 1.35_real32 + case('I') + mass_ = 126.9_real32 + charge_ = 53.0_real32 + radius_ = 1.33_real32 + case('Xe') + mass_ = 131.29_real32 + charge_ = 54.0_real32 + radius_ = 1.31_real32 + case('Cs') + mass_ = 132.91_real32 + charge_ = 55.0_real32 + radius_ = 2.35_real32 + case('Ba') + mass_ = 137.33_real32 + charge_ = 56.0_real32 + radius_ = 1.98_real32 + case('La') + mass_ = 138.91_real32 + charge_ = 57.0_real32 + radius_ = 1.69_real32 + case('Ce') + mass_ = 140.12_real32 + charge_ = 58.0_real32 + radius_ = 1.65_real32 + case('Pr') + mass_ = 140.91_real32 + charge_ = 59.0_real32 + radius_ = 1.65_real32 + case('Nd') + mass_ = 144.24_real32 + charge_ = 60.0_real32 + radius_ = 1.64_real32 + case('Pm') + mass_ = 145.0_real32 + charge_ = 61.0_real32 + radius_ = 1.63_real32 + case('Sm') + mass_ = 150.36_real32 + charge_ = 62.0_real32 + radius_ = 1.62_real32 + case('Eu') + mass_ = 152.0_real32 + charge_ = 63.0_real32 + radius_ = 1.85_real32 + case('Gd') + mass_ = 157.25_real32 + charge_ = 64.0_real32 + radius_ = 1.61_real32 + case('Tb') + mass_ = 158.93_real32 + charge_ = 65.0_real32 + radius_ = 1.59_real32 + case('Dy') + mass_ = 162.5_real32 + charge_ = 66.0_real32 + radius_ = 1.59_real32 + case('Ho') + mass_ = 164.93_real32 + charge_ = 67.0_real32 + radius_ = 1.58_real32 + case('Er') + mass_ = 167.26_real32 + charge_ = 68.0_real32 + radius_ = 1.57_real32 + case('Tm') + mass_ = 168.93_real32 + charge_ = 69.0_real32 + radius_ = 1.56_real32 + case('Yb') + mass_ = 173.05_real32 + charge_ = 70.0_real32 + radius_ = 1.74_real32 + case('Lu') + mass_ = 174.97_real32 + charge_ = 71.0_real32 + radius_ = 1.56_real32 + case('Hf') + mass_ = 178.49_real32 + charge_ = 72.0_real32 + radius_ = 1.44_real32 + case('Ta') + mass_ = 180.95_real32 + charge_ = 73.0_real32 + radius_ = 1.34_real32 + case('W') + mass_ = 183.84_real32 + charge_ = 74.0_real32 + radius_ = 1.3_real32 + case('Re') + mass_ = 186.21_real32 + charge_ = 75.0_real32 + radius_ = 1.28_real32 + case('Os') + mass_ = 190.23_real32 + charge_ = 76.0_real32 + radius_ = 1.26_real32 + case('Ir') + mass_ = 192.22_real32 + charge_ = 77.0_real32 + radius_ = 1.27_real32 + case('Pt') + mass_ = 195.08_real32 + charge_ = 78.0_real32 + radius_ = 1.3_real32 + case('Au') + mass_ = 196.97_real32 + charge_ = 79.0_real32 + radius_ = 1.34_real32 + case('Hg') + mass_ = 200.59_real32 + charge_ = 80.0_real32 + radius_ = 1.49_real32 + case('Tl') + mass_ = 204.38_real32 + charge_ = 81.0_real32 + radius_ = 1.48_real32 + case('Pb') + mass_ = 207.2_real32 + charge_ = 82.0_real32 + radius_ = 1.47_real32 + case('Bi') + mass_ = 208.98_real32 + charge_ = 83.0_real32 + radius_ = 1.46_real32 + case('Po') + mass_ = 209.0_real32 + charge_ = 84.0_real32 + radius_ = 1.45_real32 + case('At') + mass_ = 210.0_real32 + charge_ = 85.0_real32 + radius_ = 1.44_real32 + case('Rn') + mass_ = 222.0_real32 + charge_ = 86.0_real32 + radius_ = 1.43_real32 + case('Fr') + mass_ = 223.0_real32 + charge_ = 87.0_real32 + radius_ = 2.6_real32 + case('Ra') + mass_ = 226.0_real32 + charge_ = 88.0_real32 + radius_ = 2.21_real32 + case('Ac') + mass_ = 227.0_real32 + charge_ = 89.0_real32 + radius_ = 1.86_real32 + case('Th') + mass_ = 232.04_real32 + charge_ = 90.0_real32 + radius_ = 1.75_real32 + case('Pa') + mass_ = 231.04_real32 + charge_ = 91.0_real32 + radius_ = 1.61_real32 + case('U') + mass_ = 238.03_real32 + charge_ = 92.0_real32 + radius_ = 1.58_real32 + case('Np') + mass_ = 237.0_real32 + charge_ = 93.0_real32 + radius_ = 1.55_real32 + case('Pu') + mass_ = 244.0_real32 + charge_ = 94.0_real32 + radius_ = 1.53_real32 + case('Am') + mass_ = 243.0_real32 + charge_ = 95.0_real32 + radius_ = 1.51_real32 + case('Cm') + mass_ = 247.0_real32 + charge_ = 96.0_real32 + radius_ = 1.69_real32 + case('Bk') + mass_ = 247.0_real32 + charge_ = 97.0_real32 + radius_ = 1.48_real32 + case('Cf') + mass_ = 251.0_real32 + charge_ = 98.0_real32 + radius_ = 1.47_real32 + case('Es') + mass_ = 252.0_real32 + charge_ = 99.0_real32 + radius_ = 1.46_real32 + case('Fm') + mass_ = 257.0_real32 + charge_ = 100.0_real32 + radius_ = 1.45_real32 + case('Md') + mass_ = 258.0_real32 + charge_ = 101.0_real32 + radius_ = 1.44_real32 + case('No') + mass_ = 259.0_real32 + charge_ = 102.0_real32 + radius_ = 1.43_real32 + case('Lr') + mass_ = 262.0_real32 + charge_ = 103.0_real32 + radius_ = 1.62_real32 + case('Rf') + mass_ = 267.0_real32 + charge_ = 104.0_real32 + radius_ = 1.57_real32 + case('Db') + mass_ = 270.0_real32 + charge_ = 105.0_real32 + radius_ = 1.49_real32 + case('Sg') + mass_ = 271.0_real32 + charge_ = 106.0_real32 + radius_ = 1.43_real32 + case('Bh') + mass_ = 270.0_real32 + charge_ = 107.0_real32 + radius_ = 1.41_real32 + case('Hs') + mass_ = 277.0_real32 + charge_ = 108.0_real32 + radius_ = 1.34_real32 + case('Mt') + mass_ = 276.0_real32 + charge_ = 109.0_real32 + radius_ = 1.29_real32 + case('Ds') + mass_ = 281.0_real32 + charge_ = 110.0_real32 + radius_ = 1.28_real32 + case('Rg') + mass_ = 280.0_real32 + charge_ = 111.0_real32 + radius_ = 1.21_real32 + case('Cn') + mass_ = 285.0_real32 + charge_ = 112.0_real32 + radius_ = 1.22_real32 + case('Nh') + mass_ = 284.0_real32 + charge_ = 113.0_real32 + radius_ = 1.21_real32 + case('Fl') + mass_ = 289.0_real32 + charge_ = 114.0_real32 + radius_ = 1.21_real32 + case('Mc') + mass_ = 288.0_real32 + charge_ = 115.0_real32 + radius_ = 1.21_real32 + case('Lv') + mass_ = 293.0_real32 + charge_ = 116.0_real32 + radius_ = 1.21_real32 + case('Ts') + mass_ = 294.0_real32 + charge_ = 117.0_real32 + radius_ = 1.21_real32 + case('Og') + mass_ = 294.0_real32 + charge_ = 118.0_real32 + radius_ = 1.21_real32 + case default + ! handle unknown element + mass_ = 0.0_real32 + charge_ = 0.0_real32 + radius_ = 0.0_real32 + end select + + !--------------------------------------------------------------------------- + ! Return the values + !--------------------------------------------------------------------------- + if(present(mass)) mass = mass_ + if(present(charge)) charge = charge_ + if(present(radius)) radius = radius_ + + end subroutine get_element_properties +!############################################################################### + + +end module artemis__geom_rw diff --git a/src/lib/mod_edit_geom.f90 b/src/fortran/lib/mod_geom_utils.f90 similarity index 57% rename from src/lib/mod_edit_geom.f90 rename to src/fortran/lib/mod_geom_utils.f90 index 8f092e0..0180bf5 100644 --- a/src/lib/mod_edit_geom.f90 +++ b/src/fortran/lib/mod_geom_utils.f90 @@ -35,9 +35,11 @@ !!! get_wyckoff (returns an array of the similar atoms) !!! get_shortest_bond !!!############################################################################# -module edit_geom - use rw_geom, only: bas_type,geom_write,convert_bas,clone_bas - use misc, only: swap_i,swap_d,swap_vec +module artemis__geom_utils + use artemis__constants, only: real32, pi + use artemis__geom_rw, only: basis_type,geom_write + use artemis__sym, only: confine_type, gldfnd, tol_sym_default + use artemis__misc, only: swap, sort2D use misc_linalg, only: cross,outer_product,cross_matrix,uvec,modu,& get_vol,det,inverse,inverse_3x3,LUinv,reduce_vec_gcd,get_vec_multiple,& proj,GramSchmidt,LLL_reduce @@ -50,7 +52,7 @@ module edit_geom type(wyck_atom_type), allocatable, dimension(:) :: spec end type wyck_spec_type type bond_type - double precision :: length + real(real32) :: length integer, dimension(2,2) :: atoms end type bond_type @@ -60,10 +62,75 @@ module edit_geom end interface get_closest_atom -!!!updated 2023/02/16 - contains + +!############################################################################### + function compare_stoichiometry(basis1, basis2) result(output) + !! Check if two basis structures have the same stoichiometry ratio + !! + !! This function compares the stoichiometry ratios of two basis structures + !! It returns true if the relative proportions of all atomic species are + !! identical and all species names match between both structures + implicit none + type(basis_type), intent(in) :: basis1, basis2 + logical :: output + + integer :: is, js, total_atoms1, total_atoms2 + real(real32) :: ratio1, ratio2, tol + logical :: found_match + + ! Set tolerance for floating-point comparisons + tol = 1.E-5_real32 + + ! Initialize output to true, will set to false if any condition fails + output = .true. + + ! Check if both basis have the same number of species + if (basis1%nspec /= basis2%nspec) then + output = .false. + return + end if + + ! Get total number of atoms in each basis + total_atoms1 = sum(basis1%spec(:)%num) + total_atoms2 = sum(basis2%spec(:)%num) + + ! Compare each species in basis1 with corresponding species in basis2 + do is = 1, basis1%nspec + found_match = .false. + + ! Find matching species in basis2 + do js = 1, basis2%nspec + ! Check if species names match + if (basis1%spec(is)%name == basis2%spec(js)%name) then + found_match = .true. + + ! Calculate and compare stoichiometry ratios + ratio1 = real(basis1%spec(is)%num, real32) / real(total_atoms1, real32) + ratio2 = real(basis2%spec(js)%num, real32) / real(total_atoms2, real32) + + ! Check if ratios are equal within tolerance + if (abs(ratio1 - ratio2) .gt. tol) then + output = .false. + return + end if + + exit ! Found matching species, continue to next species in basis1 + end if + end do + + ! If no matching species found in basis2, stoichiometry can't be the same + if (.not. found_match) then + output = .false. + return + end if + end do + + end function compare_stoichiometry +!############################################################################### + + !!!############################################################################# !!! Normalises a 3x3 matrix to the form: !!! a 0 0 @@ -73,7 +140,7 @@ module edit_geom !!!############################################################################# function MATNORM(lat) result(nlat) implicit none - double precision, dimension(3,3) :: lat, nlat + real(real32), dimension(3,3) :: lat, nlat nlat(1,1)=sqrt(lat(1,1)**2+lat(1,2)**2+lat(1,3)**2) nlat(1,2)=0.0 nlat(1,3)=0.0 @@ -106,9 +173,9 @@ end function MATNORM function min_dist(bas,axis,loc,above) implicit none integer :: is,axis - double precision :: min_dist,pos - double precision, intent(in) :: loc - type(bas_type) :: bas + real(real32) :: min_dist,pos + real(real32), intent(in) :: loc + type(basis_type) :: bas logical :: labove logical,optional :: above @@ -117,25 +184,25 @@ function min_dist(bas,axis,loc,above) labove=.false. if(present(above)) labove=above aboveloop: if(labove)then - min_dist=huge(0.D0) + min_dist=huge(0._real32) if(all( (/ (bas%spec(is)%atom(:,axis),is=1,bas%nspec) /).lt.pos))& - pos=pos-1.D0 + pos=pos-1._real32 else - min_dist=-huge(0.D0) + min_dist=-huge(0._real32) if(all( (/ (bas%spec(is)%atom(:,axis),is=1,bas%nspec) /).gt.pos))& - pos=pos-1.D0 + pos=pos-1._real32 end if aboveloop do is=1,bas%nspec if(.not.labove.and.maxval(bas%spec(is)%atom(:,axis)-pos,& - mask=(bas%spec(is)%atom(:,axis)-pos.le.0.D0)).gt.min_dist) then + mask=(bas%spec(is)%atom(:,axis)-pos.le.0._real32)).gt.min_dist) then min_dist=maxval(bas%spec(is)%atom(:,axis)-pos,& - mask=(bas%spec(is)%atom(:,axis)-pos.le.0.D0)) + mask=(bas%spec(is)%atom(:,axis)-pos.le.0._real32)) elseif(labove.and.minval(bas%spec(is)%atom(:,axis)-pos,& - mask=(bas%spec(is)%atom(:,axis)-pos.ge.0.D0)).lt.min_dist) then + mask=(bas%spec(is)%atom(:,axis)-pos.ge.0._real32)).lt.min_dist) then min_dist=minval(bas%spec(is)%atom(:,axis)-pos,& - mask=(bas%spec(is)%atom(:,axis)-pos.ge.0.D0)) + mask=(bas%spec(is)%atom(:,axis)-pos.ge.0._real32)) end if end do @@ -149,10 +216,10 @@ end function min_dist function get_atom_height(bas,atom,axis) result(val) implicit none integer :: i,axis,atom,sum_atom - double precision :: val - type(bas_type) :: bas + real(real32) :: val + type(basis_type) :: bas - val=0.D0 + val=0._real32 sum_atom=0 do i=1,bas%nspec if(atom.le.sum_atom+bas%spec(i)%num)then @@ -170,32 +237,36 @@ end function get_atom_height !!!############################################################################# !!! returns minimum bond within bulk !!!############################################################################# - function get_min_bulk_bond(lat,bas) result(min_bond) + function get_min_bulk_bond(basis) result(min_bond) implicit none + type(basis_type), intent(in) :: basis + integer :: is,ia,js,ja - double precision :: dtmp1,min_bond - type(bas_type) :: bas - double precision, dimension(3) :: vdtmp1 - double precision, dimension(3,3) :: lat + real(real32) :: dtmp1,min_bond + real(real32), dimension(3) :: vdtmp1 - min_bond=huge(0.D0) - if(bas%natom.eq.1)then - min_bond = min(modu(lat(1,:3)),modu(lat(2,:3)),modu(lat(3,:3))) + min_bond=huge(0._real32) + if(basis%natom.eq.1)then + min_bond = min( & + modu(basis%lat(1,:3)), & + modu(basis%lat(2,:3)), & + modu(basis%lat(3,:3)) & + ) return end if - do is=1,bas%nspec - do ia=1,bas%spec(is)%num + do is = 1, basis%nspec + do ia = 1, basis%spec(is)%num - do js=1,bas%nspec - atmloop: do ja=1,bas%spec(js)%num + do js=1,basis%nspec + atmloop: do ja=1,basis%spec(js)%num if(is.eq.js.and.ia.eq.ja) cycle atmloop - vdtmp1 = bas%spec(js)%atom(ja,:3) - bas%spec(is)%atom(ia,:3) + vdtmp1 = basis%spec(js)%atom(ja,:3) - basis%spec(is)%atom(ia,:3) vdtmp1 = & - vdtmp1(1)*lat(1,:3) + & - vdtmp1(2)*lat(2,:3) + & - vdtmp1(3)*lat(3,:3) + vdtmp1(1)*basis%lat(1,:3) + & + vdtmp1(2)*basis%lat(2,:3) + & + vdtmp1(3)*basis%lat(3,:3) dtmp1 = modu(vdtmp1) if(dtmp1.lt.min_bond) min_bond = dtmp1 end do atmloop @@ -211,26 +282,25 @@ end function get_min_bulk_bond !!!############################################################################# !!! returns minimum bond for a specified atom !!!############################################################################# - function get_min_bond(lat,bas,is,ia,axis,labove,tol) result(vsave) + function get_min_bond(basis,is,ia,axis,labove,tol) result(vsave) implicit none integer :: js,ja integer :: iaxis - double precision :: dtmp1,min_bond,dtol + real(real32) :: dtmp1,min_bond,dtol logical :: ludef_above - double precision, dimension(3) :: vdtmp1, vsave + real(real32), dimension(3) :: vdtmp1, vsave integer, intent(in) :: is,ia - type(bas_type), intent(in) :: bas - double precision, dimension(3,3), intent(in) :: lat + type(basis_type), intent(in) :: basis integer, intent(in), optional :: axis - double precision, intent(in), optional :: tol + real(real32), intent(in), optional :: tol logical, intent(in), optional :: labove if(present(tol))then dtol = tol else - dtol = 1.D-5 + dtol = 1.E-5_real32 end if if(present(labove))then @@ -245,24 +315,24 @@ function get_min_bond(lat,bas,is,ia,axis,labove,tol) result(vsave) iaxis=0 end if - min_bond=huge(0.D0) + min_bond=huge(0._real32) - do js=1,bas%nspec - atmloop: do ja=1,bas%spec(js)%num + do js=1,basis%nspec + atmloop: do ja=1,basis%spec(js)%num if(is.eq.js.and.ia.eq.ja) cycle atmloop - vdtmp1 = bas%spec(js)%atom(ja,:3) - bas%spec(is)%atom(ia,:3) + vdtmp1 = basis%spec(js)%atom(ja,:3) - basis%spec(is)%atom(ia,:3) if(iaxis.gt.0)then if(abs(vdtmp1(iaxis)).lt.dtol) cycle atmloop if(ludef_above)then - vdtmp1(iaxis) = 1.D0 + vdtmp1(iaxis) + vdtmp1(iaxis) = 1._real32 + vdtmp1(iaxis) else - vdtmp1(iaxis) = vdtmp1(iaxis) - 1.D0 + vdtmp1(iaxis) = vdtmp1(iaxis) - 1._real32 end if end if vdtmp1 = & - vdtmp1(1)*lat(1,:3) + & - vdtmp1(2)*lat(2,:3) + & - vdtmp1(3)*lat(3,:3) + vdtmp1(1)*basis%lat(1,:3) + & + vdtmp1(2)*basis%lat(2,:3) + & + vdtmp1(3)*basis%lat(3,:3) dtmp1 = modu(vdtmp1) if(dtmp1.lt.min_bond)then min_bond = dtmp1 @@ -284,24 +354,24 @@ function get_min_dist(lat,bas,loc,lignore_close,axis,labove,lreal,tol) & implicit none integer :: js,ja integer :: iaxis - double precision :: dtmp1,min_bond,dtol + real(real32) :: dtmp1,min_bond,dtol logical :: ludef_above,ludef_real - double precision, dimension(3) :: vdtmp1,vdtmp2,vsave + real(real32), dimension(3) :: vdtmp1,vdtmp2,vsave logical, intent(in) :: lignore_close - type(bas_type), intent(in) :: bas - double precision, dimension(3), intent(in) :: loc - double precision, dimension(3,3), intent(in) :: lat + type(basis_type), intent(in) :: bas + real(real32), dimension(3), intent(in) :: loc + real(real32), dimension(3,3), intent(in) :: lat integer, intent(in), optional :: axis - double precision, intent(in), optional :: tol + real(real32), intent(in), optional :: tol logical, intent(in), optional :: labove, lreal !! CORRECT tol TO ACCOUNT FOR LATTICE SIZE if(present(tol))then dtol = tol else - dtol = 1.D-5 + dtol = 1.E-5_real32 end if if(present(labove))then @@ -322,8 +392,8 @@ function get_min_dist(lat,bas,loc,lignore_close,axis,labove,lreal,tol) & iaxis=0 end if - min_bond=huge(0.D0) - vsave = 0.D0 + min_bond=huge(0._real32) + vsave = 0._real32 do js=1,bas%nspec atmloop: do ja=1,bas%spec(js)%num vdtmp1 = bas%spec(js)%atom(ja,:3) - loc @@ -331,9 +401,9 @@ function get_min_dist(lat,bas,loc,lignore_close,axis,labove,lreal,tol) & if(iaxis.gt.0)then if(abs(vdtmp1(iaxis)).lt.dtol) cycle atmloop if(ludef_above)then - vdtmp1(iaxis) = 1.D0 + vdtmp1(iaxis) + vdtmp1(iaxis) = 1._real32 + vdtmp1(iaxis) else - vdtmp1(iaxis) = vdtmp1(iaxis) - 1.D0 + vdtmp1(iaxis) = vdtmp1(iaxis) - 1._real32 end if end if vdtmp2 = & @@ -360,23 +430,23 @@ end function get_min_dist !!!############################################################################# !!! Shifts the basis along a, b or c by amount 'shift' !!!############################################################################# - subroutine shifter(bas,axis,shift,ltmp) + subroutine shifter(basis,axis,shift,renormalise) implicit none - integer :: i,j,k,axis - double precision :: shift - type(bas_type) :: bas - logical, optional ::ltmp - logical :: lrenorm + type(basis_type), intent(inout) :: basis + integer, intent(in) :: axis + real(real32), intent(in) :: shift + logical, optional, intent(in) ::renormalise + integer :: i,j + logical :: renormalise_ - k=axis - lrenorm=.false. - if(present(ltmp)) lrenorm=ltmp + renormalise_=.false. + if(present(renormalise)) renormalise_ = renormalise - do i=1,bas%nspec - do j=1,bas%spec(i)%num - bas%spec(i)%atom(j,k)=bas%spec(i)%atom(j,k) + shift - if(lrenorm) bas%spec(i)%atom(j,k)=bas%spec(i)%atom(j,k) - & - floor(bas%spec(i)%atom(j,k)) + do i=1,basis%nspec + do j=1,basis%spec(i)%num + basis%spec(i)%atom(j,axis) = basis%spec(i)%atom(j,axis) + shift + if(renormalise_) basis%spec(i)%atom(j,axis) = basis%spec(i)%atom(j,axis) - & + floor(basis%spec(i)%atom(j,axis)) end do end do @@ -390,8 +460,8 @@ end subroutine shifter subroutine shift_region(bas,region_axis,region_lw,region_up,shift_axis,shift,renorm) implicit none integer :: is,ia,shift_axis,region_axis - double precision :: shift,region_lw,region_up - type(bas_type) :: bas + real(real32) :: shift,region_lw,region_up + type(basis_type) :: bas logical, optional ::renorm logical :: lrenorm @@ -420,16 +490,16 @@ end subroutine shift_region !!!############################################################################# function get_surface_normal(lat,axis) result(normal) implicit none - double precision :: component + real(real32) :: component integer, dimension(3) :: order=(/1,2,3/) - double precision, dimension(3) :: normal + real(real32), dimension(3) :: normal integer, intent(in) :: axis - double precision, dimension(3,3), intent(in) :: lat + real(real32), dimension(3,3), intent(in) :: lat order = cshift(order,3-axis) - normal = cross(lat(order(1),:),lat(order(2),:)) - component = dot_product(lat(3,:),normal) / modu(normal)**2.D0 + normal = cross([lat(order(1),:)],[lat(order(2),:)]) + component = dot_product(lat(3,:),normal) / modu(normal)**2._real32 normal = normal * component return @@ -444,16 +514,16 @@ end function get_surface_normal subroutine vacuumer(lat,bas,axis,loc,add,tol) implicit none integer :: is,ia - double precision :: rtol,rloc,ortho_scale - double precision :: cur_vac,inc,diff,mag_old,mag_new - double precision,dimension(3) :: normal + real(real32) :: rtol,rloc,ortho_scale + real(real32) :: cur_vac,inc,diff,mag_old,mag_new + real(real32),dimension(3) :: normal integer, intent(in) :: axis - double precision, intent(in) :: add,loc - type(bas_type), intent(inout) :: bas - double precision,dimension(3,3), intent(inout) :: lat + real(real32), intent(in) :: add,loc + type(basis_type), intent(inout) :: bas + real(real32),dimension(3,3), intent(inout) :: lat - double precision, optional, intent(in) :: tol + real(real32), optional, intent(in) :: tol !! get surface normal vector @@ -461,13 +531,13 @@ subroutine vacuumer(lat,bas,axis,loc,add,tol) ortho_scale = modu(lat(axis,:))/modu(normal) - rtol = 1.D-5 + rtol = 1.E-5_real32 inc = add if(present(tol)) rtol = tol cur_vac = min_dist(bas,axis,loc,.true.) - min_dist(bas,axis,loc,.false.) cur_vac = cur_vac * modu(lat(axis,:)) diff = cur_vac + inc - if(diff.lt.0.D0)then + if(diff.lt.0._real32)then write(0,*) "WARNING! Removing vacuum entirely" end if @@ -497,49 +567,48 @@ end subroutine vacuumer !!! Adjusts the amount of vacuum at a location ... !!! ... within a cell and adjusts the basis accordingly !!!############################################################################# - subroutine set_vacuum(lat,bas,axis,loc,vac,tol) + subroutine set_vacuum(basis,axis,loc,vac,tol) implicit none integer :: is,ia - double precision :: rtol,rloc,ortho_scale - double precision :: cur_vac,diff,mag_old,mag_new - double precision,dimension(3) :: normal + real(real32) :: rtol,rloc,ortho_scale + real(real32) :: cur_vac,diff,mag_old,mag_new + real(real32),dimension(3) :: normal integer, intent(in) :: axis - double precision, intent(in) :: vac,loc - type(bas_type), intent(inout) :: bas - double precision,dimension(3,3), intent(inout) :: lat + real(real32), intent(in) :: vac,loc + type(basis_type), intent(inout) :: basis - double precision, optional, intent(in) :: tol + real(real32), optional, intent(in) :: tol !! get surface normal vector - normal = get_surface_normal(lat,axis) - ortho_scale = modu(lat(axis,:))/modu(normal) + normal = get_surface_normal(basis%lat,axis) + ortho_scale = modu(basis%lat(axis,:))/modu(normal) - rtol = 0.D0 + rtol = 0._real32 if(present(tol)) rtol = tol - if(vac.lt.0.D0)then + if(vac.lt.0._real32)then write(0,*) "WARNING! Removing vacuum entirely" end if - cur_vac = min_dist(bas,axis,loc,.true.) - min_dist(bas,axis,loc,.false.) + cur_vac = min_dist(basis,axis,loc,.true.) - min_dist(basis,axis,loc,.false.) cur_vac = cur_vac * modu(normal) diff = ( vac - cur_vac ) * ortho_scale - mag_old = modu(lat(axis,:)) + mag_old = modu(basis%lat(axis,:)) mag_new = ( mag_old + diff ) / mag_old - lat(axis,:) = lat(axis,:) * mag_new - diff = diff / modu(lat(axis,:)) + basis%lat(axis,:) = basis%lat(axis,:) * mag_new + diff = diff / modu(basis%lat(axis,:)) rtol = rtol / mag_old rloc = loc / mag_new + rtol - do is=1,bas%nspec - do ia=1,bas%spec(is)%num - bas%spec(is)%atom(ia,axis) = bas%spec(is)%atom(ia,axis) / mag_new - if(bas%spec(is)%atom(ia,axis).gt.rloc) then - bas%spec(is)%atom(ia,axis) = bas%spec(is)%atom(ia,axis) + diff + do is=1,basis%nspec + do ia=1,basis%spec(is)%num + basis%spec(is)%atom(ia,axis) = basis%spec(is)%atom(ia,axis) / mag_new + if(basis%spec(is)%atom(ia,axis).gt.rloc) then + basis%spec(is)%atom(ia,axis) = basis%spec(is)%atom(ia,axis) + diff end if end do end do @@ -553,28 +622,26 @@ end subroutine set_vacuum !!! Takes a lattice and makes the defined axis orthogonal to the other two !!! WARNING! THIS IS FOR SLAB STRUCTURES! IT REMOVES PERIODICITY ALONG THAT AXIS !!!############################################################################# - subroutine ortho_axis(lat,bas,axis) + subroutine ortho_axis(basis,axis) implicit none + type(basis_type), intent(inout) :: basis integer :: axis - double precision :: ortho_comp - type(bas_type) :: bas + real(real32) :: ortho_comp integer, dimension(3) :: order - double precision, dimension(3) :: ortho_vec - double precision, dimension(3,3) :: invlat,lat + real(real32), dimension(3) :: ortho_vec + real(real32), dimension(3,3) :: lat - bas=convert_bas(bas,transpose(lat)) - order=(/1,2,3/) - order=cshift(order,3-axis) + order = [ 1, 2, 3 ] + order = cshift( order, 3 - axis ) + lat = basis%lat - ortho_vec=cross(lat(order(1),:),lat(order(2),:)) - ortho_comp=dot_product(lat(3,:),ortho_vec)/modu(ortho_vec)**2.D0 + ortho_vec=cross( [ lat(order(1),:) ] , [ lat(order(2),:) ] ) + ortho_comp=dot_product([ lat(3,:) ],ortho_vec)/modu(ortho_vec)**2._real32 ortho_vec=ortho_vec*ortho_comp lat(3,:)=ortho_vec - invlat=inverse_3x3(lat) - bas=convert_bas(bas,transpose(invlat)) - + call basis%change_lattice(lat) return end subroutine ortho_axis @@ -585,37 +652,38 @@ end subroutine ortho_axis !!! Applies a transformation matrix to a lattice ... !!! ... and extends the basis where needed !!!############################################################################# - subroutine transformer(lat,bas,tfmat,map) + subroutine transformer(basis, tfmat, map) implicit none integer :: i,j,k,l,m,n,is,ia integer :: satom,dim - double precision :: tol,vol_inc + real(real32) :: tol,vol_inc logical :: lmap - type(bas_type) :: bas,sbas + type(basis_type), intent(inout) :: basis + type(basis_type) :: sbas integer, dimension(3) :: latmin,latmax - double precision, dimension(3):: translvec,tolvec + real(real32), dimension(3):: translvec,tolvec integer, allocatable, dimension(:) :: tmp_map_atom integer, allocatable, dimension(:,:,:) :: new_map - double precision, allocatable, dimension(:,:) :: tmpbas - double precision, dimension(3,3) :: lat,slat,tfmat,invmat + real(real32), allocatable, dimension(:,:) :: tmpbas + real(real32), dimension(3,3) :: tfmat,invmat integer, allocatable, dimension(:,:,:), optional, intent(inout) :: map - vol_inc = abs(det(lat)) - if(vol_inc.lt.0.5D0)then + vol_inc = abs(det(basis%lat)) + if(vol_inc.lt.0.5_real32)then write(0,'(1X,"ERROR: Internal error in transformer function")') - write(0,'(2X,"transformer in mod_edit_geom.f90 been supplied a& + write(0,'(2X,"transformer in mod_geom_utils.f90 been supplied a& & lattice with almost zero determinant")') write(0,'(2X,"determinant = ",F0.9)') vol_inc - write(0,'(3(1X,F7.2))') lat + write(0,'(3(1X,F7.2))') basis%lat stop end if - call normalise_basis(bas,1.D0,lfloor=.true.,lround=.false.) + call basis%normalise(ceil_val = 1._real32, floor_coords = .true., round_coords = .false.) vol_inc=abs(det(tfmat)) - slat=matmul(tfmat,lat) + sbas%lat=matmul(tfmat,basis%lat) invmat=inverse_3x3(tfmat) - translvec=0.D0 - dim=size(bas%spec(1)%atom(1,:)) + translvec=0._real32 + dim=size(basis%spec(1)%atom(1,:)) !!-------------------------------------------------------------------------- @@ -628,13 +696,13 @@ subroutine transformer(lat,bas,tfmat,map) end if lmap = .true. allocate(new_map(& - bas%nspec,& - ceiling(vol_inc)*maxval(bas%spec(:)%num,dim=1),2)) + basis%nspec,& + ceiling(vol_inc)*maxval(basis%spec(:)%num,dim=1),2)) new_map=0 if(all(map.eq.0))then - do is=1,bas%nspec - map(is,:bas%spec(is)%num,1) = is - do ia=1,bas%spec(is)%num + do is=1,basis%nspec + map(is,:basis%spec(is)%num,1) = is + do ia=1,basis%spec(is)%num map(is,ia,2) = ia end do end do @@ -645,13 +713,13 @@ subroutine transformer(lat,bas,tfmat,map) !!-------------------------------------------------------------------------- !! Convert tolerance from Å to a fraction of each direction !!-------------------------------------------------------------------------- - tol=1.D-3 !! in Å + tol = 1.E-3_real32 !! in Å do i=1,3 - tolvec(i)=tol/modu(slat(i,:)) + tolvec(i)=tol/modu(sbas%lat(i,:)) end do if(vol_inc.lt.minval(tolvec))then write(0,'(1X,"ERROR: Internal error in transformer function")') - write(0,'(2X,"transformer in mod_edit_geom.f90 been supplied a& + write(0,'(2X,"transformer in mod_geom_utils.f90 been supplied a& & transformation matrix with almost zero determinant")') write(0,'(2X,"determinant = ",F0.9)') vol_inc write(0,'(3(1X,F7.2))') tfmat @@ -685,20 +753,20 @@ subroutine transformer(lat,bas,tfmat,map) !!---------------------------------- !latmin(i)=(minval(invmat(i,:))-ceiling(minval(invmat(i,:))))*vol !latmax(i)=(maxval(invmat(i,:))-floor(minval(invmat(i,:))))*vol - !latmin(i)=(min(minval(invmat(i,:)),0.D0)-ceiling(minval(invmat(i,:))))*vol + !latmin(i)=(min(minval(invmat(i,:)),0._real32)-ceiling(minval(invmat(i,:))))*vol !latmax(i)=(ceiling(maxval(invmat(i,:3)))-maxval(invmat(i,:3)) )*vol do i=1,3 - latmin(i)=floor(sum(tfmat(:3,i),mask=tfmat(:3,i).lt.0.D0))-1 - latmax(i)=ceiling(sum(tfmat(:3,i),mask=tfmat(:3,i).gt.0.D0))+1 + latmin(i)=floor(sum(tfmat(:3,i),mask=tfmat(:3,i).lt.0._real32))-1 + latmax(i)=ceiling(sum(tfmat(:3,i),mask=tfmat(:3,i).gt.0._real32))+1 end do !!-------------------------------------------------------------------------- !! transform the basis !!-------------------------------------------------------------------------- - do i=1,bas%nspec - do j=1,bas%spec(i)%num - bas%spec(i)%atom(j,:3)=matmul(bas%spec(i)%atom(j,:3),invmat) + do i=1,basis%nspec + do j=1,basis%spec(i)%num + basis%spec(i)%atom(j,:3)=matmul(basis%spec(i)%atom(j,:3),invmat) end do end do @@ -706,44 +774,44 @@ subroutine transformer(lat,bas,tfmat,map) !!-------------------------------------------------------------------------- !! generates atoms to fill the supercell !!-------------------------------------------------------------------------- - allocate(sbas%spec(bas%nspec)) - sbas%sysname=bas%sysname - sbas%nspec=0 - sbas%natom=0 - spec_loop1: do is=1,bas%nspec + allocate(sbas%spec(basis%nspec)) + sbas%sysname = basis%sysname + sbas%nspec = 0 + sbas%natom = 0 + spec_loop1: do is = 1, basis%nspec if(allocated(tmpbas)) deallocate(tmpbas) - allocate(tmpbas(bas%spec(is)%num*(& + allocate(tmpbas(basis%spec(is)%num*(& (abs(latmax(3))+abs(latmin(3))+1)*& (abs(latmax(2))+abs(latmin(2))+1)*& (abs(latmax(1))+abs(latmin(1))+1)),3)) satom=0 if(lmap)then - allocate(tmp_map_atom(ceiling(vol_inc)*bas%spec(is)%num)) + allocate(tmp_map_atom(ceiling(vol_inc)*basis%spec(is)%num)) end if - do ia=1,bas%spec(is)%num + do ia = 1, basis%spec(is)%num do n=latmin(3),latmax(3)!,1 - translvec(3)=dble(n) + translvec(3)=real(n, real32) do m=latmin(2),latmax(2)!,1 - translvec(2)=dble(m) + translvec(2)=real(m, real32) inloop: do l=latmin(1),latmax(1)!,1 - translvec(1)=dble(l) + translvec(1)=real(l, real32) tmpbas(satom+1,:3) = & - bas%spec(is)%atom(ia,:3) + matmul(translvec,invmat) + basis%spec(is)%atom(ia,:3) + matmul(translvec,invmat) !!tmpbas(satom+1,:3)=& - !! matmul((bas%spec(is)%atom(ia,:3)+translvec),invmat) + !! matmul((basis%spec(is)%atom(ia,:3)+translvec),invmat) !where(abs(tmpbas(satom+1,:3)-nint(tmpbas(satom+1,k))).lt.tol) ! tmpbas(satom+1,:3)=nint(tmpbas(satom+1,:3)) !end where - !if(any(tmpbas(satom+1,:).ge.1.D0).or.& - ! any(tmpbas(satom+1,:).lt.0.D0)) cycle - !if(any(tmpbas(satom+1,:).ge.1.D0+tol).or.& - ! any(tmpbas(satom+1,:).lt.0.D0-tol)) cycle - if(any(tmpbas(satom+1,:).ge.1.D0-tol).or.& - any(tmpbas(satom+1,:).lt.0.D0-tol)) cycle inloop !??? cycle inloop or spec_loop1? + !if(any(tmpbas(satom+1,:).ge.1._real32).or.& + ! any(tmpbas(satom+1,:).lt.0._real32)) cycle + !if(any(tmpbas(satom+1,:).ge.1._real32+tol).or.& + ! any(tmpbas(satom+1,:).lt.0._real32-tol)) cycle + if(any(tmpbas(satom+1,:).ge.1._real32-tol).or.& + any(tmpbas(satom+1,:).lt.0._real32-tol)) cycle inloop !??? cycle inloop or spec_loop1? tmpbas(satom+1,:3) = tmpbas(satom+1,:3) - & - dble(floor(tmpbas(satom+1,:3))) + real(floor(tmpbas(satom+1,:3)),real32) do k=1,satom - if(all(mod(abs(tmpbas(satom+1,:3)-tmpbas(k,:3)),1.D0).le.& + if(all(mod(abs(tmpbas(satom+1,:3)-tmpbas(k,:3)),1._real32).le.& tol)) cycle inloop end do if(lmap) tmp_map_atom(satom+1)=map(is,ia,2) @@ -759,12 +827,12 @@ subroutine transformer(lat,bas,tfmat,map) sbas%nspec=sbas%nspec+1 sbas%spec(sbas%nspec)%num=satom sbas%natom=sbas%natom+satom - sbas%spec(sbas%nspec)%name=bas%spec(is)%name + sbas%spec(sbas%nspec)%name=basis%spec(is)%name allocate(sbas%spec(sbas%nspec)%atom(satom,dim)) sbas%spec(sbas%nspec)%atom(1:satom,:3)=tmpbas(1:satom,:3) - if(dim.eq.4) sbas%spec(sbas%nspec)%atom(1:satom,4)=1.D0 + if(dim.eq.4) sbas%spec(sbas%nspec)%atom(1:satom,4)=1._real32 deallocate(tmpbas) - deallocate(bas%spec(is)%atom) + deallocate(basis%spec(is)%atom) if(lmap)then new_map(sbas%nspec,:satom,1) = is new_map(sbas%nspec,:satom,2) = tmp_map_atom(:satom) @@ -777,16 +845,16 @@ subroutine transformer(lat,bas,tfmat,map) !! check to see if successfully generated correct number of atoms !!-------------------------------------------------------------------------- if(all(abs(tfmat-nint(tfmat)).lt.tol))then - if(nint(bas%natom*vol_inc).ne.sbas%natom)then + if(nint(basis%natom*vol_inc).ne.sbas%natom)then write(0,'(1X,"ERROR: Internal error in transformer function")') - write(0,'(2X,"Transformer in mod_edit_geom.f90 has failed to & + write(0,'(2X,"Transformer in mod_geom_utils.f90 has failed to & &generate enough atoms when extending the cell")') write(0,'(2X,"Generated ",I0," atoms, whilst expecting ",I0," atoms")') & - sbas%natom,nint(bas%natom*vol_inc) - write(0,*) bas%natom,nint(vol_inc) + sbas%natom,nint(basis%natom*vol_inc) + write(0,*) basis%natom,nint(vol_inc) write(0,'(3(1X,F7.2))') tfmat open(60,file="broken_cell.vasp") - call geom_write(60,slat,sbas) + call geom_write(60,sbas) close(60) stop end if @@ -796,15 +864,15 @@ subroutine transformer(lat,bas,tfmat,map) !!-------------------------------------------------------------------------- !! saves new lattice and basis to original set !!-------------------------------------------------------------------------- - lat=slat - deallocate(bas%spec) - allocate(bas%spec(sbas%nspec)) - bas%sysname=sbas%sysname - bas%nspec=sbas%nspec - bas%natom=sbas%natom + basis%lat = sbas%lat + deallocate(basis%spec) + allocate(basis%spec(sbas%nspec)) + basis%sysname=sbas%sysname + basis%nspec=sbas%nspec + basis%natom=sbas%natom do i=1,sbas%nspec - allocate(bas%spec(i)%atom(sbas%spec(i)%num,dim)) - bas%spec(i)=sbas%spec(i) + allocate(basis%spec(i)%atom(sbas%spec(i)%num,dim)) + basis%spec(i)=sbas%spec(i) end do @@ -816,8 +884,6 @@ subroutine transformer(lat,bas,tfmat,map) call move_alloc(new_map,map) end if - - end subroutine transformer !!!############################################################################# @@ -828,9 +894,9 @@ end subroutine transformer !!!############################################################################# function change_basis(vec,old_lat,new_lat) implicit none - double precision, dimension(3) :: change_basis,vec - double precision, dimension(3,3), intent(in) :: old_lat,new_lat - double precision, dimension(3,3) :: inew_lat + real(real32), dimension(3) :: change_basis,vec + real(real32), dimension(3,3), intent(in) :: old_lat,new_lat + real(real32), dimension(3,3) :: inew_lat inew_lat=inverse_3x3(new_lat) change_basis=matmul(transpose(inew_lat),matmul(old_lat,vec)) end function change_basis @@ -843,22 +909,22 @@ end function change_basis subroutine region_rot(bas,lat,angle,axis,bound1,bound2,tvec) implicit none integer :: axis,i,j - double precision :: angle,bound1,bound2 - double precision, dimension(3) :: u,centre - double precision, dimension(3,3) :: rotmat,ident,lat,invlat - type(bas_type) :: bas - double precision, optional, dimension(3) :: tvec + real(real32) :: angle,bound1,bound2 + real(real32), dimension(3) :: u,centre + real(real32), dimension(3,3) :: rotmat,ident,lat,invlat + type(basis_type) :: bas + real(real32), optional, dimension(3) :: tvec centre=(/0.5,0.5,0.0/) if(present(tvec)) centre=tvec - ident=0.D0 + ident=0._real32 do i=1,3 - ident(i,i)=1.D0 + ident(i,i)=1._real32 end do !!! DEFINE ROTMAT BEFORE THIS - u=0.D0 - u(axis)=-1.D0 + u=0._real32 + u(axis)=-1._real32 rotmat=& (cos(angle)*ident)+& (sin(angle))*cross_matrix(u)+& @@ -887,67 +953,16 @@ end subroutine region_rot !!!############################################################################# -!!!############################################################################# -!!! convert basis coordinates to be within +val -> val-1 -!!!############################################################################# - subroutine normalise_basis(bas,dtmp,lfloor,lround,zero_round) - implicit none - integer :: is,ia,j - double precision :: ceil,flr,dround - double precision, optional :: dtmp, zero_round - type(bas_type) :: bas - logical :: lfloor1,lround1 - logical, optional :: lfloor,lround - - - ceil=1.D0 - lfloor1=.false. - if(present(dtmp)) ceil=dtmp - if(present(lfloor)) lfloor1=lfloor - flr=ceil-1.D0 - lround1=.false. - dround=1.D-8 - if(present(lround)) lround1=lround - - do is=1,bas%nspec - do ia=1,bas%spec(is)%num - do j=1,3 - if(lfloor1)then - bas%spec(is)%atom(ia,j)=bas%spec(is)%atom(ia,j)& - -floor(bas%spec(is)%atom(ia,j)-flr) - else - bas%spec(is)%atom(ia,j)=bas%spec(is)%atom(ia,j)& - -ceiling(bas%spec(is)%atom(ia,j)-ceil) - end if - if(lround1)then - if(abs(bas%spec(is)%atom(ia,j)-ceil).lt.dround.or.& - abs(bas%spec(is)%atom(ia,j)).lt.dround) & - bas%spec(is)%atom(ia,j)=flr - end if - if(present(zero_round))then - if(abs(bas%spec(is)%atom(ia,j)).lt.dround) & - bas%spec(is)%atom(ia,j)=zero_round - end if - end do - end do - end do - - - return - end subroutine normalise_basis -!!!############################################################################# - - !!!############################################################################# !!! finds the centre of geometry of the supplied basis !!!############################################################################# function centre_of_geom(bas) result(centre) implicit none integer :: is,ia,j - double precision, dimension(3) :: centre - type(bas_type) :: bas + real(real32), dimension(3) :: centre + type(basis_type) :: bas - centre=0.D0 + centre=0._real32 do is=1,bas%nspec do ia=1,bas%spec(is)%num do j=1,3 @@ -969,12 +984,12 @@ end function centre_of_geom function centre_of_mass(bas) result(centre) implicit none integer :: is,ia,j - double precision :: tot_mass - double precision, dimension(3) :: centre - type(bas_type) :: bas + real(real32) :: tot_mass + real(real32), dimension(3) :: centre + type(basis_type) :: bas - centre=0.D0 - tot_mass=0.D0 + centre=0._real32 + tot_mass=0._real32 do is=1,bas%nspec tot_mass=tot_mass+bas%spec(is)%mass*bas%spec(is)%num do ia=1,bas%spec(is)%num @@ -991,129 +1006,154 @@ end function centre_of_mass !!!############################################################################# -!!!############################################################################# -!!! Reorientates lattice to the primitive lattice of its type -!!!############################################################################# -!!! NEED TO SET UP TO WORK FOR THE EXTRA SWAPPINGS OF A, B AND C - function primitive_lat(inlat) result(plat) +!############################################################################### + subroutine primitive_lat(basis) + !! Reorientate lattice to the primitive lattice of its type + !! + !! NEED TO SET UP TO WORK FOR THE EXTRA SWAPPINGS OF A, B AND C implicit none + + ! Arguments + type(basis_type), intent(inout) :: basis + !! Structure data + + ! Local variables integer :: i,j - double precision :: dtmp1 - double precision, dimension(3) :: scal - double precision, dimension(3,3) :: lat,plat,tmat1,tmat2 - double precision, dimension(3,3), intent(in) :: inlat - double precision, dimension(4,3,3) :: special + !! Loop indices + real(real32) :: rtmp1 + !! Temporary variable + real(real32), dimension(3) :: scal + !! Scaling factors + real(real32), dimension(3,3) :: lat, plat + !! Lattice matrices + real(real32), dimension(3,3) :: tmat1, tmat2 + !! Temporary matrices + real(real32), dimension(3,3,4) :: special + !! Special lattice matrices !!--------------------------------------------------------------- !! makes all lattice vectors unity !!--------------------------------------------------------------- - lat=inlat - plat=lat - do i=1,3 - scal(i)=modu(lat(i,:)) - lat(i,:)=lat(i,:)/scal(i) + call reducer(basis) + lat = basis%lat + plat = lat + do i = 1, 3 + scal(i) = modu(lat(i,:)) + lat(i,:) = lat(i,:) / scal(i) end do !!--------------------------------------------------------------- !! sets up the special set of primitive lattices !!--------------------------------------------------------------- - special(1,:,:) = transpose( reshape( (/& - 1.D0, 0.D0, 0.D0,& - 0.D0, 1.D0, 0.D0,& - 0.D0, 0.D0, 1.D0/), shape(lat) ) ) - special(2,:,:) = transpose( reshape( (/& - 1.D0, 0.D0, 0.D0,& - -0.5D0, sqrt(3.D0)/2.D0, 0.D0,& - 0.D0, 0.D0, 1.0D0/), shape(lat) ) ) - special(3,:,:) = transpose( reshape( (/& - 0.0D0, 1.D0, 1.D0,& - 1.D0, 0.0D0, 1.D0,& - 1.D0, 1.D0, 0.0D0/), shape(lat) ) ) - special(3,:,:) = special(3,:,:)/sqrt(2.D0) - special(4,:,:) = transpose( reshape( (/& - -1.D0, 1.D0, 1.D0,& - 1.D0, -1.D0, 1.D0,& - 1.D0, 1.D0, -1.D0/), shape(lat) ) ) - special(4,:,:) = special(4,:,:)/sqrt(3.D0) + special(:,:,1) = transpose( reshape( (/& + 1._real32, 0._real32, 0._real32,& + 0._real32, 1._real32, 0._real32,& + 0._real32, 0._real32, 1._real32/), shape(lat) ) ) + special(:,:,2) = transpose( reshape( (/& + 1._real32, 0._real32, 0._real32,& + -0.5_real32, sqrt(3._real32)/2._real32, 0._real32,& + 0._real32, 0._real32, 1.0_real32/), shape(lat) ) ) + special(:,:,3) = transpose( reshape( (/& + 0.0_real32, 1._real32, 1._real32,& + 1._real32, 0._real32, 1._real32,& + 1._real32, 1._real32, 0.0_real32/), shape(lat) ) ) + special(:,:,3) = special(:,:,3) / sqrt(2._real32) + special(:,:,4) = transpose( reshape( (/& + -1._real32, 1._real32, 1._real32,& + 1._real32, -1._real32, 1._real32,& + 1._real32, 1._real32, -1._real32/), shape(lat) ) ) + special(:,:,4) = special(:,:,4) / sqrt(3._real32) !!--------------------------------------------------------------- !! cycles special set to find primitive lattice of supplied lat !!--------------------------------------------------------------- - tmat1=matmul(lat,transpose(lat)) - checkloop: do i=1,4 - !tfmat=matmul(lat,inverse_3x3(special(i,:,:))) + tmat1 = matmul(lat,transpose(lat)) + checkloop: do i = 1, 4 + !tfmat=matmul(lat,inverse_3x3(special(:,:,i))) !tfmat=matmul(tfmat,transpose(tfmat)) - tmat2=matmul(special(i,:,:),transpose(special(i,:,:))) - dtmp1=tmat2(1,1)/tmat1(1,1) - !if(all(abs(tfmat-nint(tfmat)).lt.1.D-8))then - if(all(abs(tmat1*dtmp1-tmat2).lt.1.D-8))then - do j=1,3 - plat(j,:)=scal(j)*special(i,j,:) + tmat2 = matmul(special(:,:,i),transpose(special(:,:,i))) + rtmp1 = tmat2(1,1) / tmat1(1,1) + !if(all(abs(tfmat-nint(tfmat)).lt.1.E-8_real32))then + if(all(abs(tmat1*rtmp1-tmat2).lt.1.E-6_real32))then + do j = 1, 3 + plat(j,:) = scal(j) * special(j,:,i) end do exit checkloop end if end do checkloop + basis%lat = plat - end function primitive_lat -!!!############################################################################# + end subroutine primitive_lat +!############################################################################### -!!!############################################################################# -!!! Uses Buerger's algorithm to reduce cell. -!!!############################################################################# - subroutine reducer(lat,bas,tmptype,ltmp) +!############################################################################### + subroutine reducer(basis, tmptype, verbose) + !! Reduce the cell using Buerger's algorithm implicit none - integer :: cell_type - integer :: i,j,k,count,limit - double precision, dimension(3,3) :: lat,newlat,transmat,S,tmp_mat - double precision :: tiny,pi,pi2 - logical :: verb,lreduced - integer, optional :: tmptype - logical, optional :: ltmp - type(bas_type) :: bas - + ! Arguments + type(basis_type), intent(inout) :: basis + !! Structure data + integer, intent(in), optional :: tmptype + !! Cell type + integer, intent(in), optional :: verbose + !! Verbosity level -!!!----------------------------------------------------------------------------- -!!! set up inital variable values -!!!----------------------------------------------------------------------------- - verb=.false. - if(present(ltmp)) verb=ltmp + ! Local variables + integer :: cell_type + !! Cell type + integer :: i,j,k,count,limit + !! Loop indices + real(real32), dimension(3,3) :: newlat,transmat,S,tmp_mat + !! Lattice matrices + real(real32) :: tiny,pi2 + !! Constants + integer :: verbose_ + !! Verbosity level + logical :: lreduced + !! Boolean whether cell is reduced + + + !--------------------------------------------------------------------------- + ! set up inital variable values + !--------------------------------------------------------------------------- + verbose_ = 0 + if(present(verbose)) verbose_ = verbose cell_type=2 if(present(tmptype)) cell_type=tmptype - S=0.D0 + S=0._real32 count=0 limit=100 lreduced=.false. - tiny=1E-5*(get_vol(lat))**(1.E0/3.E0) - pi=4.D0*atan(1.D0) - pi2=2.D0*atan(1.D0) - transmat=0.D0 - do i=1,3 - transmat(i,i)=1.D0 + tiny = 1.E-5_real32 * (get_vol(basis%lat))**(1._real32/3._real32) + pi2 = 2._real32*atan(1._real32) + transmat = 0._real32 + do i = 1, 3 + transmat(i,i) = 1._real32 end do - newlat=lat + newlat = basis%lat -!!!----------------------------------------------------------------------------- -!!! performs checks on the other main conditions defined by Niggli -!!!----------------------------------------------------------------------------- + !--------------------------------------------------------------------------- + ! perform checks on the other main conditions defined by Niggli + !--------------------------------------------------------------------------- find_reduced: do while(.not.lreduced) - count=count+1 - call mkNiggli_lat(lat,newlat,transmat,S) - lreduced=reduced_check(newlat,cell_type,S) + count = count + 1 + call mkNiggli_lat(basis%lat,newlat,transmat,S) + lreduced = reduced_check(newlat, cell_type, S, verbose_) if(lreduced) exit - if(verb) then - write(67,*) - write(67,*) count - write(67,*) "###############" - write(67,*) (transmat(i,:),i=1,3) - write(67,*) - write(67,*) (newlat(i,:),i=1,3) + if(verbose_.gt.1) then + write(*,*) + write(*,*) count + write(*,*) "###############" + write(*,*) (transmat(i,:),i=1,3) + write(*,*) + write(*,*) (newlat(i,:),i=1,3) end if if(count.gt.limit) then write(0,'("FAILED to find the reduced cell within ",I0," steps")') count @@ -1125,10 +1165,10 @@ subroutine reducer(lat,bas,tmptype,ltmp) do i=1,2 j=i+1 if(S(i,i)-S(j,j).gt.tiny) then - call swap_vec(transmat(i,:),transmat(j,:)) + call swap(transmat(i,:),transmat(j,:)) transmat=-transmat if(i.eq.2) cycle find_reduced - call mkNiggli_lat(lat,newlat,transmat,S) + call mkNiggli_lat(basis%lat,newlat,transmat,S) end if end do @@ -1141,7 +1181,7 @@ subroutine reducer(lat,bas,tmptype,ltmp) if(i*j*k.gt.0) then tmp_mat=reshape((/i,0,0, 0,j,0, 0,0,k/),shape(tmp_mat)) transmat=matmul(transpose(tmp_mat),transmat) - call mkNiggli_lat(lat,newlat,transmat,S) + call mkNiggli_lat(basis%lat,newlat,transmat,S) end if @@ -1153,7 +1193,7 @@ subroutine reducer(lat,bas,tmptype,ltmp) if(i*j*k.gt.0) then tmp_mat=reshape((/i,0,0, 0,j,0, 0,0,k/),shape(tmp_mat)) transmat=matmul(transpose(tmp_mat),transmat) - call mkNiggli_lat(lat,newlat,transmat,S) + call mkNiggli_lat(basis%lat,newlat,transmat,S) end if @@ -1161,12 +1201,12 @@ subroutine reducer(lat,bas,tmptype,ltmp) !! A5 if(abs(2*S(2,3)).gt.S(2,2)+tiny.or.& (abs(2*S(2,3)-S(2,2)).le.tiny.and.2*S(1,3).lt.S(1,2)).or.& - (abs(2*S(2,3)+S(2,2)).le.tiny.and.S(1,2).lt.0.D0))then + (abs(2*S(2,3)+S(2,2)).le.tiny.and.S(1,2).lt.0._real32))then tmp_mat(2,3)=((-1)**(cell_type+1))*floor((2*S(2,3)+S(2,2))/(2*S(2,2))) transmat=matmul(transpose(tmp_mat),transmat) cycle find_reduced - ! elseif(cell_type.eq.1.and.S(2,3).lt.0.D0)then - ! tmp_mat(2,3)=1.D0 + ! elseif(cell_type.eq.1.and.S(2,3).lt.0._real32)then + ! tmp_mat(2,3)=1._real32 ! transmat=matmul(transpose(tmp_mat),transmat) ! cycle find_reduced end if @@ -1175,12 +1215,12 @@ subroutine reducer(lat,bas,tmptype,ltmp) !! A6 if(abs(2*S(1,3)).gt.S(1,1)+tiny.or.& (abs(2*S(1,3)-S(1,1)).le.tiny.and.2*S(2,3).lt.S(1,2)).or.& - (abs(2*S(1,3)+S(1,1)).le.tiny.and.S(1,2).lt.0.D0))then + (abs(2*S(1,3)+S(1,1)).le.tiny.and.S(1,2).lt.0._real32))then tmp_mat(1,3)=((-1)**(cell_type+1))*floor((2*S(1,3)+S(1,1))/(2*S(1,1))) transmat=matmul(transpose(tmp_mat),transmat) cycle find_reduced - ! elseif(cell_type.eq.1.and.S(1,3).lt.0.D0)then - ! tmp_mat(1,3)=1.D0 + ! elseif(cell_type.eq.1.and.S(1,3).lt.0._real32)then + ! tmp_mat(1,3)=1._real32 ! transmat=matmul(transpose(tmp_mat),transmat) ! cycle find_reduced end if @@ -1189,12 +1229,12 @@ subroutine reducer(lat,bas,tmptype,ltmp) !! A7 if(abs(2*S(1,2)).gt.S(1,1)+tiny.or.& (abs(2*S(1,2)-S(1,1)).le.tiny.and.2*S(2,3).lt.S(1,3)).or.& - (abs(2*S(1,2)+S(1,1)).le.tiny.and.S(1,3).lt.0.D0))then + (abs(2*S(1,2)+S(1,1)).le.tiny.and.S(1,3).lt.0._real32))then tmp_mat(1,2)=((-1)**(cell_type+1))*floor((2*S(1,2)+S(1,1))/(2*S(1,1))) transmat=matmul(transpose(tmp_mat),transmat) cycle find_reduced - ! elseif(cell_type.eq.1.and.S(1,2).lt.0.D0)then - ! tmp_mat(1,2)=1.D0 + ! elseif(cell_type.eq.1.and.S(1,2).lt.0._real32)then + ! tmp_mat(1,2)=1._real32 ! transmat=matmul(transpose(tmp_mat),transmat) ! cycle find_reduced end if @@ -1217,35 +1257,33 @@ subroutine reducer(lat,bas,tmptype,ltmp) end do find_reduced - if(abs(det(transmat)+1.D0).le.tiny)then + if(abs(det(transmat)+1._real32).le.tiny)then tmp_mat=reshape((/-1,0,0, 0,-1,0, 0,0,-1/),shape(tmp_mat)) transmat=matmul(transpose(tmp_mat),transmat) end if - call mkNiggli_lat(lat,newlat,transmat,S) - lreduced=reduced_check(newlat,cell_type,S,"n") - if(verb) then - write(67,*) lreduced - write(67,*) (transmat(i,:),i=1,3) + call mkNiggli_lat(basis%lat,newlat,transmat,S) + lreduced = reduced_check(newlat, cell_type, S, verbose_) + if(verbose_.gt.1) then + write(*,*) lreduced + write(*,*) (transmat(i,:),i=1,3) end if -!!!----------------------------------------------------------------------------- -!!! Renormalises the lattice and basis into the new lattice -!!!----------------------------------------------------------------------------- - lat=newlat - do i=1,bas%nspec - do j=1,bas%spec(i)%num - bas%spec(i)%atom(j,:3)=& - matmul(bas%spec(i)%atom(j,:3),inverse_3x3(transmat)) - bas%spec(i)%atom(j,:3)=& - bas%spec(i)%atom(j,:3)-floor(bas%spec(i)%atom(j,:3)) + !--------------------------------------------------------------------------- + ! Renormalise the lattice and basis into the new lattice + !--------------------------------------------------------------------------- + basis%lat = newlat + do i = 1, basis%nspec + do j = 1, basis%spec(i)%num + basis%spec(i)%atom(j,:3) = & + matmul( basis%spec(i)%atom(j,:3), inverse_3x3(transmat) ) + basis%spec(i)%atom(j,:3) = & + basis%spec(i)%atom(j,:3) - floor( basis%spec(i)%atom(j,:3) ) end do end do - - return end subroutine reducer -!!!############################################################################# +!############################################################################### !!!############################################################################# @@ -1256,8 +1294,8 @@ end subroutine reducer !!! S(1,2) = a.b, S(1,3) = a.c, S(2,3) = b.c subroutine mkNiggli_lat(lat,newlat,transmat,S) implicit none - double precision, dimension(3,3) :: lat,newlat,transmat,S - double precision, dimension(3) :: a,b,c + real(real32), dimension(3,3) :: lat,newlat,transmat,S + real(real32), dimension(3) :: a,b,c newlat=matmul(transmat,lat) @@ -1288,32 +1326,30 @@ end subroutine mkNiggli_lat !!! Type II = Sij (i!=j) are all negative or any zero (angles >=90) !!! Cell is reduced if, and only if, all conditions are ... !!! ... satisfied (Niggli 1928) - function reduced_check(lat,cell_type,S,tchar) result(check) + function reduced_check(lat, cell_type, S, verbose) result(check) implicit none - integer :: cell_type - double precision :: tiny,alpha,beta,gamma,pi2 - double precision, dimension(3) :: a,b,c - double precision, dimension(3,3) :: lat,S - character(1) :: quiet - character(1), optional :: tchar + real(real32), dimension(3,3), intent(in) :: lat + real(real32), dimension(3,3), intent(out) :: S + integer, intent(in) :: cell_type + integer :: verbose + + real(real32) :: tiny,alpha,beta,gamma,pi2 + real(real32), dimension(3) :: a,b,c logical :: check - quiet="q" - if(present(tchar)) quiet=tchar - if(quiet.ne."y".and.quiet.ne."q") quiet="n" - pi2 = 2.D0*atan(1.D0) - check=.false. - tiny=1E-3 + pi2 = 2._real32*atan(1._real32) + check = .false. + tiny = 1.E-3_real32 - a=lat(1,:);b=lat(2,:);c=lat(3,:) - S(1,1)=dot_product(a,a) - S(2,2)=dot_product(b,b) - S(3,3)=dot_product(c,c) - S(2,3)=dot_product(b,c) - S(1,3)=dot_product(a,c) - S(1,2)=dot_product(a,b) + a = lat(1,:); b = lat(2,:); c = lat(3,:) + S(1,1) = dot_product(a,a) + S(2,2) = dot_product(b,b) + S(3,3) = dot_product(c,c) + S(2,3) = dot_product(b,c) + S(1,3) = dot_product(a,c) + S(1,2) = dot_product(a,b) alpha=acos(S(2,3)/sqrt(S(2,2)*S(3,3))) beta=acos(S(1,3)/sqrt(S(1,1)*S(3,3))) @@ -1327,29 +1363,28 @@ function reduced_check(lat,cell_type,S,tchar) result(check) end if if(cell_type.eq.1.and.& alpha.le.pi2.and.beta.le.pi2.and.gamma.le.pi2.and.& - S(1,2)-0.5D0*S(1,1).lt.tiny.and.& - S(1,3)-0.5D0*S(1,1).lt.tiny.and.& - S(2,3)-0.5D0*S(2,2).lt.tiny) then !Type I + S(1,2)-0.5_real32*S(1,1).lt.tiny.and.& + S(1,3)-0.5_real32*S(1,1).lt.tiny.and.& + S(2,3)-0.5_real32*S(2,2).lt.tiny) then !Type I check=.true. - if(quiet.eq."n") write(0,*) "Found Type I reduced Niggli cell" + if(verbose.gt.0) write(0,*) "Found Type I reduced Niggli cell" elseif(cell_type.eq.2.and.& alpha.ge.pi2-tiny.and.beta.ge.pi2-tiny.and.gamma.ge.pi2-tiny.and.& - abs(S(1,2))-0.5D0*S(1,1).lt.tiny.and.& - abs(S(1,3))-0.5D0*S(1,1).lt.tiny.and.& - abs(S(2,3))-0.5D0*S(2,2).lt.tiny.and.& - (abs(S(2,3))+abs(S(1,3))+abs(S(1,2)))-0.5D0*(S(1,1)+S(2,2)).lt.tiny) then !Type II - if(abs(S(1,2))-0.5D0*S(1,1).le.tiny.and.S(1,3).gt.tiny) return - if(abs(S(1,3))-0.5D0*S(1,1).le.tiny.and.S(1,2).gt.tiny) return - if(abs(S(2,3))-0.5D0*S(2,2).le.tiny.and.S(1,2).gt.tiny) return - if((abs(S(2,3))+abs(S(1,3))+abs(S(1,2)))-0.5D0*(S(1,1)+S(2,2)).gt.tiny.and.& - S(1,1)-(2.D0*abs(S(1,3))+abs(S(1,2))).gt.tiny) return + abs(S(1,2))-0.5_real32*S(1,1).lt.tiny.and.& + abs(S(1,3))-0.5_real32*S(1,1).lt.tiny.and.& + abs(S(2,3))-0.5_real32*S(2,2).lt.tiny.and.& + (abs(S(2,3))+abs(S(1,3))+abs(S(1,2)))-0.5_real32*(S(1,1)+S(2,2)).lt.tiny) then !Type II + if(abs(S(1,2))-0.5_real32*S(1,1).le.tiny.and.S(1,3).gt.tiny) return + if(abs(S(1,3))-0.5_real32*S(1,1).le.tiny.and.S(1,2).gt.tiny) return + if(abs(S(2,3))-0.5_real32*S(2,2).le.tiny.and.S(1,2).gt.tiny) return + if((abs(S(2,3))+abs(S(1,3))+abs(S(1,2)))-0.5_real32*(S(1,1)+S(2,2)).gt.tiny.and.& + S(1,1)-(2._real32*abs(S(1,3))+abs(S(1,2))).gt.tiny) return check=.true. - if(quiet.eq."n") write(0,*) "Found Type II reduced Niggli cell" + if(verbose.gt.1) write(0,*) "Found Type II reduced Niggli cell" else check=.false. end if - return end function reduced_check !!!############################################################################# @@ -1357,54 +1392,56 @@ end function reduced_check !!!############################################################################# !!! planecutter !!!############################################################################# - function planecutter(inlat,invec) result(tfmat) + function planecutter(lat, plane) result(tfmat) implicit none + real(real32), dimension(3,3), intent(in) :: lat + real(real32), dimension(3), intent(in) :: plane + integer :: i,j,itmp1 - double precision :: tol + real(real32) :: tol integer, dimension(3) :: order - double precision, dimension(3) :: vec,tvec1 - double precision, dimension(3,3) :: lat,b,tfmat,invlat,reclat - double precision, dimension(3), intent(in) :: invec - double precision, dimension(3,3), intent(in) :: inlat + real(real32), dimension(3) :: plane_,tvec1 + real(real32), dimension(3,3) :: lat_,b,tfmat,invlat,reclat !!!----------------------------------------------------------------------------- !!! Initialise variables and matrices !!!----------------------------------------------------------------------------- - tol=1.D-4 - vec=invec - lat=inlat - invlat=inverse(lat) - reclat=transpose(invlat) - vec=reduce_vec_gcd(vec) - order=(/1,2,3/) + tol = 1.E-4_real32 + plane_ = plane + lat_ = lat + invlat = inverse(lat_) + reclat = transpose(invlat) + if(all(plane_.le.0._real32)) plane_ = -plane_ + plane_ = reduce_vec_gcd(plane_) + order = [ 1, 2, 3 ] !!!----------------------------------------------------------------------------- !!! Align the normal vector such that all non-zero values are left of all zeros !!!----------------------------------------------------------------------------- do i=1,2 - if(vec(i).eq.0)then - if(all(vec(i:).eq.0.D0)) exit - itmp1=maxloc(vec(i+1:),mask=vec(i+1:).ne.0,dim=1)+i - call swap_i(order(i),order(itmp1)) - call swap_d(vec(i),vec(itmp1)) - call swap_vec(lat(:,i),lat(:,itmp1)) - call swap_vec(lat(i,:),lat(itmp1,:)) - call swap_vec(reclat(:,i),reclat(:,itmp1)) - call swap_vec(reclat(i,:),reclat(itmp1,:)) + if(plane_(i).eq.0)then + if(all(plane_(i:).eq.0._real32)) exit + itmp1=maxloc(plane_(i+1:),mask=plane_(i+1:).ne.0,dim=1)+i + call swap(order(i),order(itmp1)) + call swap(plane_(i),plane_(itmp1)) + call swap(lat_(:,i),lat_(:,itmp1)) + call swap(lat_(i,:),lat_(itmp1,:)) + call swap(reclat(:,i),reclat(:,itmp1)) + call swap(reclat(i,:),reclat(itmp1,:)) end if end do - !vec=matmul(vec,reclat) + !plane_=matmul(plane_,reclat) !!!----------------------------------------------------------------------------- !!! Perform Lenstra-Lenstra-Lovász reduction !!!----------------------------------------------------------------------------- - b(1,:) = (/-vec(2),vec(1),0.D0/) - b(2,:) = (/-vec(3),0.D0,vec(1)/) - b(3,:) = vec + b(1,:) = [ -plane_(2),plane_(1),0._real32 ] + b(2,:) = [ -plane_(3),0._real32,plane_(1) ] + b(3,:) = plane_ tfmat = b b(:2,:) = LLL_reduce(b(:2,:)) @@ -1415,7 +1452,7 @@ function planecutter(inlat,invec) result(tfmat) !!!----------------------------------------------------------------------------- if(dot_product(b(1,:),b(3,:)).gt.tol)then write(0,'("ERROR: Internatl error in planecutter")') - write(0,'(2X,"Error in planecutter subroutine in mod_edit_geom.f90")') + write(0,'(2X,"Error in planecutter subroutine in mod_geom_utils.f90")') write(0,'(2X,"b1 not perpendicular to b3")') write(0,'(2X,"b1 = ",3(1X,F0.3))') b(1,:) write(0,'(2X,"b3 = ",3(1X,F0.3))') b(3,:) @@ -1425,7 +1462,7 @@ function planecutter(inlat,invec) result(tfmat) stop elseif(dot_product(b(2,:),b(3,:)).gt.tol)then write(0,'("ERROR: Internatl error in planecutter")') - write(0,'(2X,"Error in planecutter subroutine in mod_edit_geom.f90")') + write(0,'(2X,"Error in planecutter subroutine in mod_geom_utils.f90")') write(0,'(2X,"b2 not perpendicular to b3")') write(0,'(2X,"b2 = ",3(1X,F6.2))') b(2,:) write(0,'(2X,"b3 = ",3(1X,F6.2))') b(3,:) @@ -1435,7 +1472,7 @@ function planecutter(inlat,invec) result(tfmat) stop elseif(dot_product(b(1,:),b(1,:)).lt.tol)then write(0,'("ERROR: Internatl error in planecutter")') - write(0,'(2X,"Error in planecutter subroutine in mod_edit_geom.f90")') + write(0,'(2X,"Error in planecutter subroutine in mod_geom_utils.f90")') write(0,'(2X,"b1 has zero size")') write(0,'(2X,"b1 = ",3(1X,F6.2))') b(1,:) write(0,'("Inform developers of this issue")') @@ -1443,7 +1480,7 @@ function planecutter(inlat,invec) result(tfmat) stop elseif(dot_product(b(2,:),b(2,:)).lt.tol)then write(0,'("ERROR: Internatl error in planecutter")') - write(0,'(2X,"Error in planecutter subroutine in mod_edit_geom.f90")') + write(0,'(2X,"Error in planecutter subroutine in mod_geom_utils.f90")') write(0,'(2X,"b2 has zero size")') write(0,'(2X,"b2 = ",3(1X,F6.2))') b(2,:) write(0,'("Inform developers of this issue")') @@ -1451,7 +1488,7 @@ function planecutter(inlat,invec) result(tfmat) stop end if - !b = matmul(b,lat) + !b = matmul(b,lat_) !!!----------------------------------------------------------------------------- @@ -1459,10 +1496,10 @@ function planecutter(inlat,invec) result(tfmat) !!!----------------------------------------------------------------------------- do i=1,3 if(i.eq.order(i)) cycle - call swap_vec(lat(i,:),lat(order(i),:)) - call swap_vec(lat(:,i),lat(:,order(i))) - call swap_vec(b(:,i),b(:,order(i))) - call swap_i(order(order(i)),order(i)) + call swap(lat_(i,:),lat_(order(i),:)) + call swap(lat_(:,i),lat_(:,order(i))) + call swap(b(:,i),b(:,order(i))) + call swap(order(order(i)),order(i)) end do @@ -1472,35 +1509,35 @@ function planecutter(inlat,invec) result(tfmat) !!!----------------------------------------------------------------------------- !b=matmul(b,invlat) where(abs(b(:,:)).lt.tol) - b(:,:)=0.D0 + b(:,:)=0._real32 end where !write(0,'(3(2X,F9.3))') (b(j,:),j=1,3) !write(0,*) reduce_loop: do i=1,3 b(i,:)=reduce_vec_gcd(b(i,:)) if(any(abs(b(i,:)-nint(b(i,:))).gt.tol))then - write(0,'("Issue with plane ",3(1X,I0))') nint(invec) - write(0,*) vec + write(0,'("Issue with plane ",3(1X,I0))') nint(plane) + write(0,*) plane_ write(0,'("row ",I0," of the following matrix")') i write(0,'(3(2X,F9.3))') (b(j,:),j=1,3) write(0,'(1X,"ERROR: Internal error in planecutter function")') - write(0,'(2X,"Planecutter in mod_edit_geom.f90 is unable to find a& + write(0,'(2X,"Planecutter in mod_geom_utils.f90 is unable to find a& & perpendicular plane")') - b=0.D0 + b=0._real32 exit end if end do reduce_loop - if(det(b).lt.0.D0)then - tvec1=b(2,:) - b(2,:)=b(1,:) - b(1,:)=tvec1 + if(det(b).lt.0._real32)then + tvec1 = b(2,:) + b(2,:) = b(1,:) + b(1,:) = tvec1 end if if(abs(det(b)).lt.tol)then write(0,'(1X,"ERROR: Internal error in planecutter function")') - write(0,'(2X,"Planecutter in mod_edit_geom.f90 has generated a 0& + write(0,'(2X,"Planecutter in mod_geom_utils.f90 has generated a 0& & determinant matrix")') write(0,'(3(2X,F9.3))') (b(j,:),j=1,3) - b=0.D0 + b=0._real32 !stop end if tfmat=b @@ -1511,209 +1548,269 @@ end function planecutter !!!############################################################################# -!!!############################################################################# -!!! merges two supplied bases -!!!############################################################################# -!!! Assumes the same lattice for each - function bas_merge(bas1,bas2,length,map1,map2) result(mergbas) +!############################################################################### + function basis_merge(basis1,basis2,length,map1,map2) result(output) + !! Merge two supplied bases + !! + !! Merge two bases assuming that the lattice is the same implicit none - integer :: i,j,k,itmp,dim + + ! Arguments + type(basis_type) :: output + !! Output merged basis. + class(basis_type), intent(in) :: basis1, basis2 + !! Input bases to merge. + integer, intent(in), optional :: length + !! Number of dimensions for atomic positions (default 3). + integer, allocatable, dimension(:,:,:), optional, intent(inout) :: map1,map2 + !! Maps for atoms in the two bases. + + ! Local variables + integer :: i, j, k, itmp, dim + !! Loop counters. logical :: lmap + !! Boolean for map presence. integer, allocatable, dimension(:) :: match + !! Array to match species. integer, allocatable, dimension(:,:,:) :: new_map + !! New map for merged basis. - type(bas_type) :: mergbas - type(bas_type), intent(in) :: bas1,bas2 - integer, intent(in), optional :: length - integer, allocatable, dimension(:,:,:), optional, intent(inout) :: map1,map2 - !!-------------------------------------------------------------------------- - !! Set up number of species - !!-------------------------------------------------------------------------- + !--------------------------------------------------------------------------- + ! set up number of species + !--------------------------------------------------------------------------- dim=3 if(present(length)) dim=length - allocate(match(bas2%nspec)) + allocate(match(basis2%nspec)) match=0 - mergbas%nspec=bas1%nspec - do i=1,bas2%nspec - if(.not.any(bas2%spec(i)%name.eq.bas1%spec(:)%name))then - mergbas%nspec=mergbas%nspec+1 + output%nspec=basis1%nspec + do i = 1, basis2%nspec + if(.not.any(basis2%spec(i)%name.eq.basis1%spec(:)%name))then + output%nspec=output%nspec+1 end if end do - allocate(mergbas%spec(mergbas%nspec)) - mergbas%spec(:bas1%nspec)%num=bas1%spec(:)%num - mergbas%spec(:bas1%nspec)%name=bas1%spec(:)%name - - - write(mergbas%sysname,'(A,"+",A)') & - trim(bas1%sysname),trim(bas2%sysname) - k=bas1%nspec - spec1check: do i=1,bas2%nspec - do j=1,bas1%nspec - if(bas2%spec(i)%name.eq.bas1%spec(j)%name)then - mergbas%spec(j)%num=mergbas%spec(j)%num+bas2%spec(i)%num + allocate(output%spec(output%nspec)) + output%spec(:basis1%nspec)%num=basis1%spec(:)%num + output%spec(:basis1%nspec)%name=basis1%spec(:)%name + + + write(output%sysname,'(A,"+",A)') & + trim(basis1%sysname),trim(basis2%sysname) + k=basis1%nspec + spec1check: do i = 1, basis2%nspec + do j = 1, basis1%nspec + if(basis2%spec(i)%name.eq.basis1%spec(j)%name)then + output%spec(j)%num=output%spec(j)%num+basis2%spec(i)%num match(i)=j cycle spec1check end if end do k=k+1 match(i)=k - mergbas%spec(k)%num=bas2%spec(i)%num - mergbas%spec(k)%name=bas2%spec(i)%name + output%spec(k)%num=basis2%spec(i)%num + output%spec(k)%name=basis2%spec(i)%name end do spec1check - !!-------------------------------------------------------------------------- - !! If map is present, sets up new map - !!-------------------------------------------------------------------------- + !--------------------------------------------------------------------------- + ! if map is present, sets up new map + !--------------------------------------------------------------------------- lmap = .false. if_map: if(present(map1).and.present(map2))then if(all(map1.eq.-1)) exit if_map lmap = .true. allocate(new_map(& - mergbas%nspec,& - maxval(mergbas%spec(:)%num,dim=1),2)) + output%nspec,& + maxval(output%spec(:)%num,dim=1),2)) new_map = 0 end if if_map - !!-------------------------------------------------------------------------- - !! Set up atoms in merged basis - !!-------------------------------------------------------------------------- - do i=1,bas1%nspec - allocate(mergbas%spec(i)%atom(mergbas%spec(i)%num,dim)) - mergbas%spec(i)%atom(:,:)=0.D0 - mergbas%spec(i)%atom(1:bas1%spec(i)%num,:3)=bas1%spec(i)%atom(:,:3) - if(lmap) new_map(i,:bas1%spec(i)%num,:)=map1(i,:bas1%spec(i)%num,:) + !--------------------------------------------------------------------------- + ! set up atoms in merged basis + !--------------------------------------------------------------------------- + do i = 1, basis1%nspec + allocate(output%spec(i)%atom(output%spec(i)%num,dim)) + output%spec(i)%atom(:,:)=0._real32 + output%spec(i)%atom(1:basis1%spec(i)%num,:3)=basis1%spec(i)%atom(:,:3) + if(lmap) new_map(i,:basis1%spec(i)%num,:)=map1(i,:basis1%spec(i)%num,:) end do - do i=1,bas2%nspec - if(match(i).gt.bas1%nspec)then - allocate(mergbas%spec(match(i))%atom(mergbas%spec(match(i))%num,dim)) - mergbas%spec(match(i))%atom(:,:)=0.D0 - mergbas%spec(match(i))%atom(:,:3)=bas2%spec(i)%atom(:,:3) - if(lmap) new_map(match(i),:bas2%spec(i)%num,:) = & - map2(i,:bas2%spec(i)%num,:) + do i = 1, basis2%nspec + if(match(i).gt.basis1%nspec)then + allocate(output%spec(match(i))%atom(output%spec(match(i))%num,dim)) + output%spec(match(i))%atom(:,:)=0._real32 + output%spec(match(i))%atom(:,:3)=basis2%spec(i)%atom(:,:3) + if(lmap) new_map(match(i),:basis2%spec(i)%num,:) = & + map2(i,:basis2%spec(i)%num,:) else - itmp=bas1%spec(match(i))%num - mergbas%spec(match(i))%atom(itmp+1:bas2%spec(i)%num+itmp,:3) = & - bas2%spec(i)%atom(:,:3) - if(lmap) new_map(match(i),itmp+1:bas2%spec(i)%num+itmp,:) = & - map2(i,:bas2%spec(i)%num,:) + itmp=basis1%spec(match(i))%num + output%spec(match(i))%atom(itmp+1:basis2%spec(i)%num+itmp,:3) = & + basis2%spec(i)%atom(:,:3) + if(lmap) new_map(match(i),itmp+1:basis2%spec(i)%num+itmp,:) = & + map2(i,:basis2%spec(i)%num,:) end if end do - mergbas%natom=sum(mergbas%spec(:)%num) + output%natom=sum(output%spec(:)%num) + output%lat = basis1%lat if(lmap) call move_alloc(new_map,map1) return - end function bas_merge -!!!############################################################################# + end function basis_merge +!############################################################################### -!!!############################################################################# -!!! merges two supplied bases and lattices -!!! Does so by stitching one onto the top of the other -!!!############################################################################# - subroutine bas_lat_merge(merglat,mergbas,inlat1,inlat2,inbas1,inbas2,axis,inoffset,map1,map2) +!############################################################################### + function basis_stack(basis1,basis2,axis,offset,length,map1,map2) result(output) + !! Merge two supplied bases + !! + !! Merge two bases assuming that the lattice is the same implicit none - integer :: i,k,axis - double precision :: c1_ratio,c2_ratio,add,loc,zgap - type(bas_type) :: mergbas,bas1,bas2 - type(bas_type), intent(in) :: inbas1,inbas2 - integer, dimension(3) :: order - double precision, dimension(3) :: unit_vec,offset - double precision, dimension(3), intent(in) :: inoffset - double precision, dimension(3,3) :: merglat,lat1,lat2 - double precision, dimension(3,3), intent(in) :: inlat1,inlat2 + ! Arguments + type(basis_type) :: output + !! Output merged basis. + class(basis_type), intent(in) :: basis1, basis2 + !! Input bases to merge. + integer, intent(in), optional :: length + !! Number of dimensions for atomic positions (default 3). + integer, intent(in) :: axis + !! Axis for the offset. + real(real32), dimension(3), intent(in) :: offset + !! Offset for the merged basis. integer, allocatable, dimension(:,:,:), optional, intent(inout) :: map1,map2 + !! Maps for atoms in the two bases. + + ! Local variables + integer :: i, j, k, length_ + !! Loop counters. + real(real32) :: loc, c1_ratio, c2_ratio, zgap, add + !! Lattice parameters. + type(basis_type) :: basis1_, basis2_ + integer, dimension(3) :: order + !! Order of axes. + real(real32), dimension(3) :: unit_vec + !! Unit vector for the axis. + real(real32), dimension(3) :: offset_ + !! Offset for the merged basis. + integer, allocatable, dimension(:) :: match + !! Array to match species. + real(real32), dimension(3,3) :: output_lat + !! Output lattice. - offset=inoffset - if(allocated(mergbas%spec))then - do i=1,mergbas%nspec - if(allocated(mergbas%spec(i)%atom)) deallocate(mergbas%spec(i)%atom) + + !--------------------------------------------------------------------------- + ! copy basis1 and basis2 + !--------------------------------------------------------------------------- + call basis1_%copy(basis1) + call basis2_%copy(basis2) + + + !--------------------------------------------------------------------------- + ! set up number of species + !--------------------------------------------------------------------------- + length_ = 3 + if(present(length)) length_ = length + + allocate(match(basis2_%nspec)) + match=0 + output%nspec=basis1_%nspec + do i = 1, basis2_%nspec + if(.not.any(basis2_%spec(i)%name.eq.basis1_%spec(:)%name))then + output%nspec=output%nspec+1 + end if + end do + allocate(output%spec(output%nspec)) + output%spec(:basis1_%nspec)%num=basis1_%spec(:)%num + output%spec(:basis1_%nspec)%name=basis1_%spec(:)%name + + + write(output%sysname,'(A,"+",A)') & + trim(basis1_%sysname),trim(basis2_%sysname) + k=basis1_%nspec + spec1check: do i = 1, basis2_%nspec + do j = 1, basis1_%nspec + if(basis2_%spec(i)%name.eq.basis1_%spec(j)%name)then + output%spec(j)%num=output%spec(j)%num+basis2_%spec(i)%num + match(i)=j + cycle spec1check + end if end do - deallocate(mergbas%spec) - end if + k=k+1 + match(i)=k + output%spec(k)%num=basis2_%spec(i)%num + output%spec(k)%name=basis2_%spec(i)%name + end do spec1check - call clone_bas(inbas1,bas1,inlat1,lat1) - call clone_bas(inbas2,bas2,inlat2,lat2) -!!!----------------------------------------------------------------------------- -!!! Shifts cells to -!!!----------------------------------------------------------------------------- + + !----------------------------------------------------------------------------- + ! Shifts cells to + !----------------------------------------------------------------------------- loc=0.D0 - lat1=MATNORM(lat1) - add=-min_dist(bas1,axis,loc,.true.) - call shifter(bas1,axis,add,.true.) + basis1_%lat=MATNORM(basis1_%lat) + add = -min_dist(basis1_,axis,loc,.true.) + call shifter(basis1_,axis,add,.true.) - add=-min_dist(bas2,axis,loc,.true.) - lat2=MATNORM(lat2) - call shifter(bas2,axis,add,.true.) + basis2_%lat=MATNORM(basis2_%lat) + add = -min_dist(basis2_,axis,loc,.true.) + call shifter(basis2_,axis,add,.true.) -!!!----------------------------------------------------------------------------- -!!! reduces vacuum between materials to desired sizes -!!!----------------------------------------------------------------------------- - loc=1.D0 - call set_vacuum(lat1,bas1,axis,loc,offset(axis)) - call set_vacuum(lat2,bas2,axis,loc,offset(axis)) - - order=(/1,2,3/) - order=cshift(order,3-axis) - do k=1,2 - offset(order(k))=offset(order(k))/modu(lat1(order(k),:)) - end do - unit_vec=uvec(lat1(order(3),:)) - zgap=offset(order(3))/unit_vec(order(3)) - !!NOT SET UP OFFSET FEATURE MADE ABOVE!!! MIGHT BE FIXED NOW! NEED TO TEST - !loc=1.D0 - !add=zgap+min_dist(bas1,axis,loc)*modu(lat1(axis,:)) - !call vacuumer(lat1,bas1,axis,loc,add) + !--------------------------------------------------------------------------- + ! handle offset + !--------------------------------------------------------------------------- + loc = 1._real32 + call set_vacuum(basis1_,axis,loc,offset(axis)) + call set_vacuum(basis2_,axis,loc,offset(axis)) + + order = [ 1, 2, 3 ] + order = cshift(order,3-axis) + do k = 1, 2 + offset_(order(k)) = offset(order(k)) / modu(basis1_%lat(order(k),:)) + end do + unit_vec = uvec(basis1_%lat(order(3),:)) + zgap = offset_(order(3)) / unit_vec(order(3)) - !add=zgap+min_dist(bas2,axis,loc)*modu(lat2(axis,:)) - !call vacuumer(lat2,bas2,axis,loc,add) -!!!----------------------------------------------------------------------------- -!!! makes supercell -!!!----------------------------------------------------------------------------- - merglat(order(1),:)=lat1(order(1),:) - merglat(order(2),:)=lat1(order(2),:) - unit_vec=uvec(lat1(axis,:)) - ! slat(axis,:)=lat1(axis,:) + ( modu(lat2(axis,:)) + zgap/unit_vec(axis) )*unit_vec - merglat(axis,:)=lat1(axis,:) + modu(lat2(axis,:))*unit_vec - c1_ratio=modu(lat1(axis,:))/modu(merglat(axis,:)) - c2_ratio=modu(lat2(axis,:))/modu(merglat(axis,:)) + !--------------------------------------------------------------------------- + ! makes supercell + !--------------------------------------------------------------------------- + output_lat(order(1),:) = basis1_%lat(order(1),:) + output_lat(order(2),:) = basis1_%lat(order(2),:) + unit_vec = uvec(basis1_%lat(axis,:)) + output_lat(axis,:) = basis1_%lat(axis,:) + modu(basis2_%lat(axis,:)) * unit_vec + c1_ratio = modu(basis1_%lat(axis,:)) / modu(output_lat(axis,:)) + c2_ratio = modu(basis2_%lat(axis,:)) / modu(output_lat(axis,:)) !!!----------------------------------------------------------------------------- !!! merge list of atomic types and respective numbers for both structures !!!----------------------------------------------------------------------------- - do i=1,bas1%nspec - bas1%spec(i)%atom(:,axis)=bas1%spec(i)%atom(:,axis)*c1_ratio + do i=1,basis1_%nspec + basis1_%spec(i)%atom(:,axis) = basis1_%spec(i)%atom(:,axis) * c1_ratio end do - do i=1,bas2%nspec - bas2%spec(i)%atom(:,axis)=bas2%spec(i)%atom(:,axis)*c2_ratio + c1_ratio + do i=1,basis2_%nspec + basis2_%spec(i)%atom(:,axis) = basis2_%spec(i)%atom(:,axis)*c2_ratio + c1_ratio do k=1,2 - bas2%spec(i)%atom(:,order(k))=bas2%spec(i)%atom(:,order(k))+offset(order(k)) + basis2_%spec(i)%atom(:,order(k)) = basis2_%spec(i)%atom(:,order(k)) + offset_(order(k)) end do end do if(present(map1).and.present(map2))then - mergbas=bas_merge(bas1,bas2,map1=map1,map2=map2) + output = basis_merge(basis1_,basis2_,map1=map1,map2=map2) else - mergbas=bas_merge(bas1,bas2) + output = basis_merge(basis1_,basis2_) end if - call normalise_basis(mergbas,1.D0,.true.) + output%lat = output_lat + call output%normalise(ceil_val = 1._real32, floor_coords = .true.) - - return - end subroutine bas_lat_merge -!!!############################################################################# + end function basis_stack +!############################################################################### !!!############################################################################# @@ -1724,13 +1821,13 @@ function split_bas(inbas,loc_vec,axis,lall_same_nspec,map1,map2) result(bas_arr) integer :: i,is,ia,itmp1,nregions,axis,nspec logical :: lsame logical :: lmap,lmove - type(bas_type) :: tbas - double precision, allocatable, dimension(:,:) :: dloc_vec + type(basis_type) :: tbas + real(real32), allocatable, dimension(:,:) :: dloc_vec logical, optional :: lall_same_nspec - type(bas_type),intent(in) :: inbas - double precision, dimension(:,:), intent(in) :: loc_vec - type(bas_type), allocatable, dimension(:) :: bas_arr + type(basis_type),intent(in) :: inbas + real(real32), dimension(:,:), intent(in) :: loc_vec + type(basis_type), allocatable, dimension(:) :: bas_arr type map_type integer, allocatable, dimension(:,:,:) :: spec @@ -1758,7 +1855,7 @@ function split_bas(inbas,loc_vec,axis,lall_same_nspec,map1,map2) result(bas_arr) allocate(dloc_vec(nregions,2)) dloc_vec(:,:)=loc_vec(:,:)-floor(loc_vec(:,:)) where(dloc_vec(:,2).lt.dloc_vec(:,1)) - dloc_vec(:,2)=dloc_vec(:,2)+1.D0 + dloc_vec(:,2)=dloc_vec(:,2)+1._real32 end where allocate(bas_arr(nregions)) @@ -1769,6 +1866,7 @@ function split_bas(inbas,loc_vec,axis,lall_same_nspec,map1,map2) result(bas_arr) regionloop1: do i=1,nregions bas_arr(i)%natom = 0 bas_arr(i)%nspec = inbas%nspec + bas_arr(i)%lat = inbas%lat write(bas_arr(i)%sysname,'(A,"_region_",I0)') trim(inbas%sysname),i allocate(bas_arr(i)%spec(inbas%nspec)) if(lmap) allocate(map(i)%spec(bas_arr(i)%nspec,maxval(inbas%spec(:)%num),2)) @@ -1806,6 +1904,7 @@ function split_bas(inbas,loc_vec,axis,lall_same_nspec,map1,map2) result(bas_arr) tbas%nspec=count(bas_arr(i)%spec(:)%num.gt.0) tbas%natom=bas_arr(i)%natom tbas%sysname=bas_arr(i)%sysname + tbas%lat = inbas%lat allocate(tbas%spec(tbas%nspec)) if(lmap.and.i.eq.1)then @@ -1832,17 +1931,144 @@ function split_bas(inbas,loc_vec,axis,lall_same_nspec,map1,map2) result(bas_arr) end if nspec=nspec+1 end do specloop2 - call clone_bas(tbas,bas_arr(i)) + call bas_arr(i)%copy(tbas) deallocate(tbas%spec) end do end if - + end function split_bas +!!!############################################################################# - end function split_bas !!!############################################################################# +!!! returns the primitive cell from a supercell +!!!############################################################################# + subroutine get_primitive_cell(basis, tol_sym) + implicit none + type(basis_type), intent(inout) :: basis + real(real32), intent(in), optional :: tol_sym + + integer :: is,ia,ja,i,j,k,itmp1 + integer :: ntrans,len + real(real32) :: scale,projection,dtmp1 + real(real32) :: tol_sym_ + type(confine_type) :: confine + real(real32), dimension(3,3) :: dmat1,invlat + real(real32), allocatable, dimension(:,:) :: trans,atom_store + + + !!----------------------------------------------------------------------- + !! Allocate and initialise + !!----------------------------------------------------------------------- + tol_sym_ = tol_sym_default + if(present(tol_sym)) tol_sym_ = tol_sym + ntrans = 0 + dmat1=0._real32 + allocate(trans(minval(basis%spec(:)%num+2),3)); trans=0._real32 + + + !!----------------------------------------------------------------------- + !! Find the translation vectors in the cell + !!----------------------------------------------------------------------- + call gldfnd(confine,basis,basis,trans,ntrans,tol_sym,.false.) + len=size(basis%spec(1)%atom,dim=2) + + + !!----------------------------------------------------------------------- + !! For each translation, reduce the basis + !!----------------------------------------------------------------------- + if(ntrans.ge.1)then + do i=ntrans+1,ntrans+3 + trans(i,:)=0._real32 + trans(i,i-ntrans)=1._real32 + end do + ! trans=matmul(trans(1:ntrans,1:3),basis%lat) + call sort2D( [ trans(1:ntrans+3,:) ] ,ntrans+3) + !! for each lattice vector, determine the shortest translation ... + !! ... vector that has a non-zero projection along that lattice vector. + do i=1,3 + projection=1.E2_real32 + trans_loop: do j=1,ntrans+3 + dtmp1 = dot_product(trans(j,:),trans(ntrans+i,:)) + if(dtmp1.lt.tol_sym) cycle trans_loop + + do k=1,i-1,1 + if(modu(abs(cross( [ trans(j,:) ], [ dmat1(k,:) ]))).lt.1.E-8_real32) cycle trans_loop + end do + + dtmp1 = modu( [ trans(j,:) ] ) + if(dtmp1.lt.projection)then + projection=dtmp1 + dmat1(i,:) = trans(j,:) + trans(j,:) = 0._real32 + end if + end do trans_loop + end do + !dmat1=trans(1:3,1:3) + scale=det(dmat1) + dmat1=matmul(dmat1,basis%lat) + invlat=inverse_3x3(dmat1) + do is=1,basis%nspec + itmp1=0 + allocate(atom_store(nint(scale*basis%spec(is)%num),len)) + atcheck: do ia=1,basis%spec(is)%num + !!----------------------------------------------------------------- + !! Reduce the basis + !!----------------------------------------------------------------- + basis%spec(is)%atom(ia,1:3)=& + matmul(basis%spec(is)%atom(ia,1:3),basis%lat(1:3,1:3)) + basis%spec(is)%atom(ia,1:3)=& + matmul(transpose(invlat(1:3,1:3)),basis%spec(is)%atom(ia,1:3)) + do j=1,3 + basis%spec(is)%atom(ia,j)=& + basis%spec(is)%atom(ia,j)-floor(basis%spec(is)%atom(ia,j)) + if(basis%spec(is)%atom(ia,j).gt.1._real32-tol_sym) & + basis%spec(is)%atom(ia,j)=0._real32 + end do + !!----------------------------------------------------------------- + !! Check for duplicates in the cell + !!----------------------------------------------------------------- + do ja=1, itmp1 + if(all(abs(basis%spec(is)%atom(ia,1:3)-atom_store(ja,1:3)).lt.& + [ tol_sym,tol_sym,tol_sym ])) cycle atcheck + end do + itmp1=itmp1+1 + atom_store(itmp1,:)=basis%spec(is)%atom(ia,:) + !!----------------------------------------------------------------- + !! Check to ensure correct number of atoms remain after reduction + !!----------------------------------------------------------------- + if(itmp1.gt.size(atom_store,dim=1))then + write(0,*) "ERROR! Primitive cell subroutine retained too & + &many atoms from supercell!", itmp1, size(atom_store,dim=1) + call exit() + end if + !!----------------------------------------------------------------- + end do atcheck + deallocate(basis%spec(is)%atom) + call move_alloc(atom_store,basis%spec(is)%atom) + basis%spec(is)%num=size(basis%spec(is)%atom,dim=1) + !deallocate(atom_store) + end do + !!----------------------------------------------------------------------- + !! Reduce the lattice + !!----------------------------------------------------------------------- + basis%natom=sum(basis%spec(:)%num) + basis%lat=dmat1 + end if + + + !!----------------------------------------------------------------------- + !! Reduce the lattice to symmetry definition + !!----------------------------------------------------------------------- + !! next line necessary as FCC and BCC do not conform to Niggli reduced ... + !! ... cell definitions. + call primitive_lat(basis) + + + + end subroutine get_primitive_cell +!!!############################################################################# !!!############################################################################# !!! returns the bulk basis and lattice of @@ -1851,23 +2077,22 @@ subroutine get_bulk(lat,bas,axis,bulk_lat,bulk_bas) implicit none integer :: is,ia,ja,len,itmp1 integer :: minspecloc,minatomloc,nxtatomloc - double precision, dimension(3) :: transvec - double precision, dimension(2,2) :: regions - double precision, dimension(3,3) :: tf + real(real32), dimension(3) :: transvec + real(real32), dimension(2,2) :: regions logical, allocatable, dimension(:) :: atom_mask - type(bas_type), allocatable, dimension(:) :: splitbas + type(basis_type), allocatable, dimension(:) :: splitbas integer, intent(in) :: axis - type(bas_type), intent(in) :: bas - double precision, dimension(3,3), intent(in):: lat - type(bas_type), intent(out) :: bulk_bas - double precision, dimension(3,3), intent(out) :: bulk_lat + type(basis_type), intent(in) :: bas + real(real32), dimension(3,3), intent(in):: lat + type(basis_type), intent(out) :: bulk_bas + real(real32), dimension(3,3), intent(out) :: bulk_lat minspecloc = minloc(bas%spec(:)%num,mask=bas%spec(:)%num.ne.0,dim=1) if(bas%spec(minspecloc)%num.eq.1)then write(0,'("ERROR: Internal error in get_bulk")') - write(0,'(2X,"get_bulk subroutine in mod_edit_geom.f90 unable cannot & + write(0,'(2X,"get_bulk subroutine in mod_geom_utils.f90 unable cannot & &find enough atoms to reproduce a bulk from")') stop end if @@ -1918,7 +2143,7 @@ subroutine get_bulk(lat,bas,axis,bulk_lat,bulk_bas) atom_loop2: do ja=1,splitbas(2)%spec(is)%num if( all( abs( ( splitbas(1)%spec(is)%atom(ia,:3) + transvec ) - & - splitbas(2)%spec(is)%atom(ja,:3) ).lt.1.D-5 ) )then + splitbas(2)%spec(is)%atom(ja,:3) ).lt.1.E-5_real32 ) )then write(0,*) ia,ja cycle atom_loop1 @@ -1946,14 +2171,8 @@ subroutine get_bulk(lat,bas,axis,bulk_lat,bulk_bas) bulk_lat(axis,:) = matmul(transvec,lat) - tf=matmul(inverse(bulk_lat),lat) - write(0,*) tf - call clone_bas(splitbas(1),bulk_bas) - bulk_bas = convert_bas(splitbas(1),tf) - - - - + call bulk_bas%copy(splitbas(1)) + call bulk_bas%change_lattice(bulk_lat) end subroutine get_bulk !!!############################################################################# @@ -1966,23 +2185,23 @@ function get_centre_atom(bas,spec,axis,lw,up) result(iatom) implicit none integer :: ia integer :: iatom - double precision :: dtmp1,dtmp2,centre - double precision :: dlw,dup + real(real32) :: dtmp1,dtmp2,centre + real(real32) :: dlw,dup integer, intent(in) :: spec,axis - double precision, intent(in) :: lw,up - type(bas_type), intent(in) :: bas + real(real32), intent(in) :: lw,up + type(basis_type), intent(in) :: bas iatom=0 - dtmp1 = 1.D0 + dtmp1 = 1._real32 if(lw.gt.up)then dlw = lw - dup = 1.D0 + up + dup = 1._real32 + up else dlw = lw dup = up end if - centre = (dlw + dup)/2.D0 + centre = (dlw + dup)/2._real32 do ia=1,bas%spec(spec)%num dtmp2=bas%spec(spec)%atom(ia,axis)& -ceiling(bas%spec(spec)%atom(ia,axis)-dup) @@ -2004,19 +2223,19 @@ function get_closest_atom_1D(bas,axis,loc,species,above,below) result(atom) implicit none integer :: is,ia integer :: is_start,is_end - double precision :: dtmp1,dtmp2 + real(real32) :: dtmp1,dtmp2 logical :: labove,lbelow integer, intent(in) :: axis - double precision, intent(in) :: loc + real(real32), intent(in) :: loc integer, dimension(2) :: atom - type(bas_type), intent(in) :: bas + type(basis_type), intent(in) :: bas integer, optional, intent(in) :: species logical, optional, intent(in) :: above,below atom=[0,0] - dtmp1 = 1.D0 + dtmp1 = 1._real32 if(present(species))then is_start=species is_end=species @@ -2037,7 +2256,7 @@ function get_closest_atom_1D(bas,axis,loc,species,above,below) result(atom) cycle atom_loop1 end if dtmp2=bas%spec(is)%atom(ia,axis)& - -ceiling(bas%spec(is)%atom(ia,axis)-(loc+0.5D0)) + -ceiling(bas%spec(is)%atom(ia,axis)-(loc+0.5_real32)) if(abs(dtmp2-loc).lt.dtmp1)then dtmp1=abs(dtmp2-loc) atom=[is,ia] @@ -2055,18 +2274,18 @@ function get_closest_atom_3D(lat,bas,loc,species) result(atom) implicit none integer :: is,ia integer :: is_start,is_end - double precision :: dtmp1,dtmp2 - double precision, dimension(3) :: vtmp1 - double precision, dimension(3), intent(in) :: loc - double precision, dimension(3,3), intent(in) :: lat + real(real32) :: dtmp1,dtmp2 + real(real32), dimension(3) :: vtmp1 + real(real32), dimension(3), intent(in) :: loc + real(real32), dimension(3,3), intent(in) :: lat integer, dimension(2) :: atom - type(bas_type), intent(in) :: bas + type(basis_type), intent(in) :: bas integer, optional, intent(in) :: species atom=[0,0] - dtmp1 = 1.D0 + dtmp1 = 1._real32 if(present(species))then is_start=species is_end=species @@ -2078,7 +2297,7 @@ function get_closest_atom_3D(lat,bas,loc,species) result(atom) spec_loop1: do is=is_start,is_end atom_loop1: do ia=1,bas%spec(is)%num vtmp1 = bas%spec(is)%atom(ia,:) - loc - vtmp1 = vtmp1 - ceiling(vtmp1 - 0.5D0) + vtmp1 = vtmp1 - ceiling(vtmp1 - 0.5_real32) vtmp1 = matmul(vtmp1,lat) dtmp2 = modu(vtmp1) if(dtmp2.lt.dtmp1)then @@ -2100,12 +2319,13 @@ function get_wyckoff(bas,axis) result(wyckoff) implicit none integer :: is,ia,ja,itmp1,itmp2!ref_atom integer :: minspecloc,minatomloc,nxtatomloc - double precision :: up_loc,lw_loc,up_loc2,lw_loc2 - double precision, dimension(3) :: transvec,tmp_vec1,tmp_vec2,tmp_vec3,tvec + real(real32) :: up_loc,lw_loc,up_loc2,lw_loc2 + real(real32), dimension(3) :: transvec,tmp_vec1,tmp_vec2,tmp_vec3,tvec logical, allocatable, dimension(:) :: atom_mask type(wyck_spec_type) :: wyckoff integer, intent(in) :: axis - type(bas_type), intent(in) :: bas + type(basis_type), intent(in) :: bas + real(real32), dimension(3) :: tol type l_bulk_type logical, allocatable, dimension(:) :: atom @@ -2119,14 +2339,19 @@ function get_wyckoff(bas,axis) result(wyckoff) !!! Finds upper and lower locations for "slab" and finds atom nearest to the ... !!! ... centre of that region !!!----------------------------------------------------------------------------- + tol = 1.E-1_real32 + do ia = 1, 3 + tol(ia) = tol(ia) / norm2(bas%lat(ia,:)) + end do + minspecloc = minloc(bas%spec(:)%num,mask=bas%spec(:)%num.ne.0,dim=1) minatomloc = minloc(bas%spec(minspecloc)%atom(:,axis),dim=1) nxtatomloc = maxloc(bas%spec(minspecloc)%atom(:,axis),dim=1) lw_loc = bas%spec(minspecloc)%atom(minatomloc,axis) up_loc = bas%spec(minspecloc)%atom(nxtatomloc,axis) minatomloc = & - maxloc(bas%spec(minspecloc)%atom(:,axis)-(lw_loc+up_loc)/2.D0,dim=1,& - mask=bas%spec(minspecloc)%atom(:,axis)-(lw_loc+up_loc)/2.D0.le.0.D0) + maxloc(bas%spec(minspecloc)%atom(:,axis)-(lw_loc+up_loc)/2._real32,dim=1,& + mask=bas%spec(minspecloc)%atom(:,axis)-(lw_loc+up_loc)/2._real32.le.0._real32) allocate(atom_mask(bas%spec(minspecloc)%num)) atom_mask = .true. @@ -2141,7 +2366,7 @@ function get_wyckoff(bas,axis) result(wyckoff) !!!----------------------------------------------------------------------------- itmp1 = minatomloc lw_loc = bas%spec(minspecloc)%atom(minatomloc,axis) - up_loc = 1.D0 + up_loc = 1._real32 allocate(l_bulk_atoms(bas%nspec)) do is=1,bas%nspec allocate(l_bulk_atoms(is)%atom(bas%spec(is)%num)) @@ -2164,7 +2389,7 @@ function get_wyckoff(bas,axis) result(wyckoff) end where if(all(.not.atom_mask))then write(0,'("ERROR: Internal error in get_wyckoff")') - write(0,'(2X,"Error in subroutine get_wyckoff in mod_edit_geom.f90")') + write(0,'(2X,"Error in subroutine get_wyckoff in mod_geom_utils.f90")') write(0,'(2X,"No bulk found")') write(0,'(2X,"Exiting subroutine...")') return @@ -2188,10 +2413,10 @@ function get_wyckoff(bas,axis) result(wyckoff) !! Checks atoms within a region to see if they reproduce layer above !!----------------------------------------------------------------------- up_loc = lw_loc + transvec(axis) - !if(lw_loc.eq.up_loc) up_loc = up_loc + 1.D-8 !! IS THIS NEEDED? + !if(lw_loc.eq.up_loc) up_loc = up_loc + 1.E-8_real32 !! IS THIS NEEDED? if(lw_loc.gt.up_loc)then write(0,'("ERROR: Internal error in get_wyckoff")') - write(0,'(2X,"Error in subroutine get_wyckoff in mod_edit_geom.f90")') + write(0,'(2X,"Error in subroutine get_wyckoff in mod_geom_utils.f90")') write(0,'(2X,"Region size is negative")') write(0,'(2X,"Stopping...")') stop @@ -2211,12 +2436,10 @@ function get_wyckoff(bas,axis) result(wyckoff) bas%spec(is)%atom(ja,:3) !! SAME ISSUE HERE AS BELOW !! NEED TO TAKE INTO ACCOUNT THAT THEY WORK IN UNISON - tmp_vec2 = tmp_vec2 - ceiling( tmp_vec2 - 0.5D0 ) + tmp_vec2 = tmp_vec2 - ceiling( tmp_vec2 - 0.5_real32 ) - if( all( abs(tmp_vec2).lt.1.D-5 ) )then - cycle atom_loop1 - end if + if( all( abs(tmp_vec2).lt.tol ) ) cycle atom_loop1 end do atom_loop2 itmp1 = nxtatomloc @@ -2241,11 +2464,11 @@ function get_wyckoff(bas,axis) result(wyckoff) if(bas%spec(is)%atom(ia,axis).lt.lw_loc2.or.& bas%spec(is)%atom(ia,axis).ge.up_loc2) cycle atom_loop3 tmp_vec1 = bas%spec(is)%atom(ia,:3) + transvec - if( all(bas%spec(is)%atom(:,axis).lt.tmp_vec1(axis)-1.D-5) ) cycle atom_loop3 + if( all(bas%spec(is)%atom(:,axis).lt.tmp_vec1(axis)-tol(axis)) ) cycle atom_loop3 atom_loop4: do ja=1,bas%spec(is)%num tmp_vec2 = tmp_vec1 - bas%spec(is)%atom(ja,:3) - tmp_vec2 = tmp_vec2 - ceiling( tmp_vec2 - 0.5D0 ) - if( all( abs(tmp_vec2).lt.1.D-5 ) )then + tmp_vec2 = tmp_vec2 - ceiling( tmp_vec2 - 0.5_real32 ) + if( all( abs(tmp_vec2).lt.tol ) )then cycle atom_loop3 end if end do atom_loop4 @@ -2264,10 +2487,21 @@ function get_wyckoff(bas,axis) result(wyckoff) !!----------------------------------------------------------------------- exit region_loop1 - end do region_loop1 + !--------------------------------------------------------------------------- + ! Apply tolerances to the bulk cell + !--------------------------------------------------------------------------- + do is = 1, bas%nspec + do ia = 1, bas%spec(is)%num + if(bas%spec(is)%atom(ia,axis) + tol(axis).ge.lw_loc.and.& + bas%spec(is)%atom(ia,axis) - tol(axis).lt.up_loc)then + l_bulk_atoms(is)%atom(ia)=.true. + end if + end do + end do + !!!----------------------------------------------------------------------------- !!! Using the bulk definition, loop runs through checking which atom maps ... @@ -2281,6 +2515,7 @@ function get_wyckoff(bas,axis) result(wyckoff) atom_loop5: do ia=1,bas%spec(is)%num if(l_bulk_atoms(is)%atom(ia))then wyckoff%spec(is)%atom(ia) = ia + cycle atom_loop5 end if !write(0,*) is,ia,l_bulk_atoms(is)%atom(ia) tmp_vec2 = bas%spec(is)%atom(ia,:3) @@ -2289,17 +2524,17 @@ function get_wyckoff(bas,axis) result(wyckoff) tmp_vec3 = tmp_vec2 - bas%spec(is)%atom(ja,:3) itmp1 = nint(tmp_vec3(axis)/transvec(axis)) tvec = itmp1*transvec - tvec = tvec - ceiling(tvec-1.D0) + tvec = tvec - ceiling(tvec-1._real32) !tmp_vec3 = tmp_vec3/transvec !tmp_vec3 = reduce_vec_gcd(tmp_vec3) itmp2 = nint(get_vec_multiple(tvec,tmp_vec3)) if(itmp1.eq.0) cycle atom_loop6 tmp_vec3 = tmp_vec3 - tvec!itmp1*tvec - tmp_vec3 = tmp_vec3 - ceiling(tmp_vec3 - 0.5D0) + tmp_vec3 = tmp_vec3 - ceiling(tmp_vec3 - 0.5_real32) !THIS IS WHERE WE NEED TO MAKE IT RIGHT !! FIND THE GCD AND DIVIDE - if(all(abs(tmp_vec3).lt.1.D-5))then + if(all(abs(tmp_vec3).lt.tol))then if(wyckoff%spec(is)%atom(ja).ne.0)then wyckoff%spec(is)%atom(ia) = wyckoff%spec(is)%atom(ja) else @@ -2313,7 +2548,7 @@ function get_wyckoff(bas,axis) result(wyckoff) if(any(wyckoff%spec(is)%atom(:).eq.0))then write(0,'("ERROR: Internal error in get_wyckoff")') - write(0,'(2X,"Error in subroutine get_wyckoff in mod_edit_geom.f90")') + write(0,'(2X,"Error in subroutine get_wyckoff in mod_geom_utils.f90")') write(0,'(2X,"Not all wyckoff atoms found")') do ia=1,bas%spec(is)%num write(0,*) is,ia,wyckoff%spec(is)%atom(ia) @@ -2334,35 +2569,35 @@ end function get_wyckoff !!!############################################################################# !!! identify the shortest bond in the crystal, takes in crystal basis !!!############################################################################# - function get_shortest_bond(lat,bas) result(bond) + function get_shortest_bond(basis) result(bond) implicit none + type(basis_type), intent(in) :: basis + integer :: is,js,ia,ja,ja_start - double precision :: dist,min_bond - type(bas_type), intent(in) :: bas + real(real32) :: dist,min_bond type(bond_type) :: bond - double precision, dimension(3) :: vec + real(real32), dimension(3) :: vec integer, dimension(2,2) :: atoms - double precision, dimension(3,3) :: lat - min_bond = 100.D0 + min_bond = huge(0._real32) atoms = 0 - do is=1,bas%nspec - do js=is,bas%nspec - do ia=1,bas%spec(is)%num + do is = 1, basis%nspec + do js = is, basis%nspec + do ia = 1, basis%spec(is)%num if(is.eq.js)then - ja_start = ia+1 + ja_start = ia + 1 else ja_start = 1 end if - do ja=ja_start,bas%spec(js)%num - vec = bas%spec(is)%atom(ia,:3) - bas%spec(js)%atom(ja,:3) - vec = vec - ceiling(vec - 0.5D0) - vec = matmul(vec,lat) + do ja=ja_start,basis%spec(js)%num + vec = basis%spec(is)%atom(ia,:3) - basis%spec(js)%atom(ja,:3) + vec = vec - ceiling(vec - 0.5_real32) + vec = matmul(vec,basis%lat) dist = modu(vec) if(dist.lt.min_bond)then min_bond = dist - atoms(1,:) = (/is, ia/) - atoms(2,:) = (/js, ja/) + atoms(1,:) = [ is, ia ] + atoms(2,:) = [ js, ja ] end if end do end do @@ -2371,54 +2606,175 @@ function get_shortest_bond(lat,bas) result(bond) bond%length = min_bond bond%atoms = atoms - end function get_shortest_bond !!!############################################################################# -!!!############################################################################# -!!! shares strain between two lattices -!!!############################################################################# - subroutine share_strain(lat1,lat2,bulk_mod1,bulk_mod2,axis,lcompensate) +!############################################################################### + subroutine share_strain_scalar( & + basis1, basis2, & + bulk_mod1, bulk_mod2, & + axis, lcompensate & + ) + !! Share strain between two lattices implicit none - integer :: i - integer :: iaxis - double precision :: area1,area2,delta1,delta2 - integer, dimension(3) :: abc=(/1,2,3/) - double precision, dimension(3) :: strain - - double precision, intent(in) :: bulk_mod1,bulk_mod2 - double precision, dimension(3,3), intent(inout) :: lat1,lat2 + ! Arguments + type(basis_type), intent(inout) :: basis1, basis2 + !! Structures + real(real32), intent(in) :: bulk_mod1, bulk_mod2 + !! Bulk modulus of the two structures integer, optional, intent(in) :: axis + !! Axis along which to share strain logical, optional, intent(in) :: lcompensate + !! Boolean whether to compensate for the strain in the axis direction - iaxis=3 - if(present(axis)) iaxis=axis + ! Local variables + integer :: i + !! Loop index + integer :: axis_ + !! Axis index + real(real32) :: area1, area2, delta1, delta2 + !! Area of the two lattices + integer, dimension(3) :: abc = [ 1, 2, 3 ] + !! Array to hold the axis indices + real(real32), dimension(3) :: strain + !! Strain vector + + + axis_ = 3 + if(present(axis)) axis_ = axis - abc=cshift(abc,3-iaxis) - area1 = modu(cross(lat1(abc(1),:),lat1(abc(2),:))) - area2 = modu(cross(lat2(abc(1),:),lat2(abc(2),:))) - delta1 = - (1.D0 - area2/area1)/(1.D0 + (area2/area1)*(bulk_mod1/bulk_mod2)) - delta2 = - (1.D0 - area1/area2)/(1.D0 + (area1/area2)*(bulk_mod2/bulk_mod1)) + abc=cshift(abc,3-axis_) + area1 = modu(cross(basis1%lat(abc(1),:),basis1%lat(abc(2),:))) + area2 = modu(cross(basis2%lat(abc(1),:),basis2%lat(abc(2),:))) + delta1 = - (1._real32 - area2/area1)/(1._real32 + (area2/area1)*(bulk_mod1/bulk_mod2)) + delta2 = - (1._real32 - area1/area2)/(1._real32 + (area1/area2)*(bulk_mod2/bulk_mod1)) write(0,*) "areas", area1,area2 write(0,*) "deltas", delta1,delta2 write(0,*) "modulus", bulk_mod1,bulk_mod2 do i=1,3 - if(i.eq.iaxis) cycle - strain(:) = lat1(i,:)-lat2(i,:) - lat1(i,:) = lat1(i,:) * (1.D0 + delta1) - lat2(i,:) = lat1(i,:) + if(i.eq.axis_) cycle + strain(:) = basis1%lat(i,:)-basis2%lat(i,:) + basis1%lat(i,:) = basis1%lat(i,:) * (1._real32 + delta1) + basis2%lat(i,:) = basis1%lat(i,:) end do if(present(lcompensate))then if(lcompensate)then - lat1(abc(3),:) = lat1(abc(3),:) * (1.D0 - delta1/(1.D0 + delta1)) - lat2(abc(3),:) = lat2(abc(3),:) * (1.D0 - delta2/(1.D0 + delta2)) + basis1%lat(abc(3),:) = basis1%lat(abc(3),:) * (1._real32 - delta1/(1._real32 + delta1)) + basis2%lat(abc(3),:) = basis2%lat(abc(3),:) * (1._real32 - delta2/(1._real32 + delta2)) end if end if - end subroutine share_strain -!!!############################################################################# + end subroutine share_strain_scalar +!############################################################################### + + +!############################################################################### + subroutine share_strain_tensor( & + basis1, basis2, & + elastic_tensor1, elastic_tensor2, & + axis, lcompensate & + ) + !! Share strain between two lattices + implicit none + + ! Arguments + type(basis_type), intent(inout) :: basis1, basis2 + !! Structures + real(real32), dimension(6,6), intent(in) :: elastic_tensor1, elastic_tensor2 + !! Elastic tensors of the two structures + integer, optional, intent(in) :: axis + !! Axis along which to compensate strain + logical, optional, intent(in) :: lcompensate + !! Boolean whether to compensate for the strain in the axis direction + + ! Local variables + integer :: i, j, a1, a2, a3, axis_ + real(real32) :: s, s_opt, e_total, e_total_min + logical :: lcompensate_ + integer, dimension(3) :: abc = [1, 2, 3] + real(real32), dimension(3,3) :: def_mat, F + real(real32), dimension(2,2) :: A, B, Finv + real(real32), dimension(3,3) :: strain_tensor, ident + real(real32), dimension(6) :: strain1_voigt, strain2_voigt + real(real32) :: e1, e2, total_area + + ! Initialise optional arguments + axis_ = 3 + lcompensate_ = .false. + if (present(axis)) axis_ = axis + if (present(lcompensate)) lcompensate_ = lcompensate + + ! Align axes so interface is in a1-a2 plane + abc = cshift(abc, 3 - axis_) + a1 = abc(1); a2 = abc(2); a3 = abc(3) + + ! Get in-plane lattice vectors + A = basis1%lat([a1,a2], [a1,a2]) + B = basis2%lat([a1,a2], [a1,a2]) + + ! Compute deformation gradient from basis1 to basis2 + Finv = inverse(A) + F = 0._real32 + F(1:2,1:2) = matmul(B, Finv) + F(3,3) = 1._real32 + + ! Compute symmetric strain tensor: ε = 0.5 * (FᵀF - I) + def_mat = matmul(transpose(F), F) + ident = 0._real32 + ident(1,1) = 1._real32; ident(2,2) = 1._real32; ident(3,3) = 1._real32 + strain_tensor = 0.5_real32 * (def_mat - ident) + + ! Total interface strain (applied to both): convert to Voigt + strain1_voigt = 0._real32 + strain2_voigt = 0._real32 + strain1_voigt(1) = strain_tensor(a1,a1) + strain1_voigt(2) = strain_tensor(a2,a2) + strain1_voigt(6) = 2._real32 * strain_tensor(a1,a2) + strain2_voigt = strain1_voigt ! same total strain + + ! Optimise strain split between materials + e_total_min = huge(0._real32) + do i = 0, 100 + s = real(i,real32) / 100._real32 + strain1_voigt = s * strain1_voigt + strain2_voigt = (1._real32 - s) * strain2_voigt + e1 = 0.5_real32 * dot_product(strain1_voigt, matmul(elastic_tensor1, strain1_voigt)) + e2 = 0.5_real32 * dot_product(strain2_voigt, matmul(elastic_tensor2, strain2_voigt)) + e_total = e1 + e2 + if (e_total .lt. e_total_min) then + e_total_min = e_total + s_opt = s + end if + end do + + ! Apply optimal strain split + strain1_voigt = s_opt * strain1_voigt + strain2_voigt = (1._real32 - s_opt) * strain2_voigt + + ! Apply to lattices + do i = 1, 2 + basis1%lat(abc(i),:) = basis1%lat(abc(i),:) * (1._real32 + strain1_voigt(i)) + basis2%lat(abc(i),:) = basis2%lat(abc(i),:) * (1._real32 + strain2_voigt(i)) + end do + ! Apply shear via angle (if any) + basis1%lat(a1,:) = basis1%lat(a1,:) + 0.5_real32 * strain1_voigt(6) * basis1%lat(a2,:) + basis2%lat(a2,:) = basis2%lat(a2,:) + 0.5_real32 * strain2_voigt(6) * basis2%lat(a1,:) + + ! Out-of-plane compensation + if (lcompensate_) then + basis1%lat(a3,:) = basis1%lat(a3,:) * (1._real32 - strain1_voigt(1) - strain1_voigt(2)) + basis2%lat(a3,:) = basis2%lat(a3,:) * (1._real32 - strain2_voigt(1) - strain2_voigt(2)) + end if + + ! Print + write(*,'(A,F6.2,A,F6.2,A)') " Strain % shared: ", s_opt*100._real32, "% / ", (1._real32 - s_opt)*100._real32, "%" + write(*,'(A,F10.6)') " Total strain energy: ", e_total_min + + + end subroutine share_strain_tensor +!############################################################################### -end module edit_geom +end module artemis__geom_utils diff --git a/src/mod_help.f90 b/src/fortran/lib/mod_help.f90 similarity index 81% rename from src/mod_help.f90 rename to src/fortran/lib/mod_help.f90 index 34c8091..51e4e97 100644 --- a/src/mod_help.f90 +++ b/src/fortran/lib/mod_help.f90 @@ -1,8 +1,13 @@ module mod_help - use io + use artemis__io_utils, only: err_abort, tag_type, io_print_help implicit none - private !everything is private unless explicitly defined as public + + private + + public :: settings_help + public :: cell_edits_help + public :: interface_help ! logical, save :: ltag_present(ntags) !!!REPLACE READVAR WITH THIS @@ -24,12 +29,12 @@ module mod_help ! Cell_edits number of tags - integer, parameter :: ntags_cell_edits=12 + integer, parameter :: ntags_cell_edits=15 ! Cell_edits tags integer, parameter :: iout_file_tag=1 integer, parameter :: ilsurf_gen_CE_tag=2 integer, parameter :: imiller_tag=3 - integer, parameter :: islab_thick_tag=4 + integer, parameter :: inum_layers_tag=4 integer, parameter :: ishift_tag=5 integer, parameter :: ishift_region_tag=6 integer, parameter :: ivacuum_tag=7 @@ -38,10 +43,17 @@ module mod_help integer, parameter :: ilortho_CE_tag=10 integer, parameter :: isurf_tag=11 integer, parameter :: ilnorm_lat_tag=12 + integer, parameter :: imin_thick_tag=13 + integer, parameter :: iuse_pricel_tag=14 + integer, parameter :: irequire_stoich_tag=15 + + integer, parameter :: ntags_depr_cell_edits=1 + ! Cell_edits deprecated tags + integer, parameter :: islab_thick_tag=1 ! Interface number of tags - integer, parameter :: ntags_interface=54 + integer, parameter :: ntags_interface=59 ! Interface tags integer, parameter :: inintf_tag=1 integer, parameter :: iimatch_tag=2 @@ -50,8 +62,8 @@ module mod_help integer, parameter :: iaxis_tag=5 integer, parameter :: ilw_miller_tag=6 integer, parameter :: iup_miller_tag=7 - integer, parameter :: ilw_thick_tag=8 - integer, parameter :: iup_thick_tag=9 + integer, parameter :: ilw_num_layers_tag=8 + integer, parameter :: iup_num_layers_tag=9 integer, parameter :: ishiftdir_tag=10 integer, parameter :: iishift_tag=11 integer, parameter :: inshift_tag=12 @@ -97,19 +109,21 @@ module mod_help integer, parameter :: ilw_bulk_modulus_tag=52 integer, parameter :: iup_bulk_modulus_tag=53 integer, parameter :: ilc_fix_tag=54 + integer, parameter :: ilbreak_on_no_term_tag=55 + integer, parameter :: ilw_min_thick_tag=56 + integer, parameter :: iup_min_thick_tag=57 + integer, parameter :: ilw_require_stoich_tag=58 + integer, parameter :: iup_require_stoich_tag=59 + integer, parameter :: ntags_depr_interface=2 + ! Cell_edits deprecated tags + integer, parameter :: ilw_slab_thick_tag=1 + integer, parameter :: iup_slab_thick_tag=2 - public :: settings_help - public :: cell_edits_help - public :: interface_help - - -!!!updated 2023/03/27 - - contains + !!!############################################################################# !!! setup settings tag descriptions !!!############################################################################# @@ -306,14 +320,44 @@ function setup_cell_edits_tags() result(tag) 'Prints the surface terminations of a Miller plane into DTERMINATIONS & &directory' - tag(islab_thick_tag)%name = 'SLAB_THICKNESS' - tag(islab_thick_tag)%type = 'I' - tag(islab_thick_tag)%summary = 'Thickness of slab' - tag(islab_thick_tag)%allowed = 'Any positive integer number' - tag(islab_thick_tag)%default = '3' - tag(islab_thick_tag)%description = & + tag(inum_layers_tag)%name = 'NUM_LAYERS' + tag(inum_layers_tag)%type = 'I' + tag(inum_layers_tag)%summary = 'Number of layers of crystal' + tag(inum_layers_tag)%allowed = 'Any positive integer number' + tag(inum_layers_tag)%default = '(empty)' + tag(inum_layers_tag)%description = & 'Defines the number of primitive layers to use for the slab' + tag(imin_thick_tag)%name = 'MIN_THICKNESS' + tag(imin_thick_tag)%type = 'R' + tag(imin_thick_tag)%summary = 'Minimum thickness of slab' + tag(imin_thick_tag)%allowed = 'Any positive real number' + tag(imin_thick_tag)%default = '10.0' + tag(imin_thick_tag)%description = & + 'Defines the minimum thickness of the lower crystal (in Å).\n& + &The generated slab will be the smallest possible thickness equal to & + &or greater than this value.' + + tag(iuse_pricel_tag)%name = 'USE_PRICEL' + tag(iuse_pricel_tag)%type = 'L' + tag(iuse_pricel_tag)%summary = 'Use primitive cell' + tag(iuse_pricel_tag)%allowed = 'TRUE or FALSE' + tag(iuse_pricel_tag)%default = 'TRUE' + tag(iuse_pricel_tag)%description = & + 'Defines whether to generate and use the primitive unit cell & + &for the crystal' + + tag(irequire_stoich_tag)%name = 'REQUIRE_STOICH' + tag(irequire_stoich_tag)%type = 'L' + tag(irequire_stoich_tag)%summary = 'Maintain stoichiometry for terminations' + tag(irequire_stoich_tag)%allowed = 'TRUE or FALSE' + tag(irequire_stoich_tag)%default = 'FALSE' + tag(irequire_stoich_tag)%description = & + 'Defines whether to maintain stoichiometry for the terminations.\n& + &If TRUE, ARTEMIS will only generate terminations that are consistent & + &with the stoichiometry of the bulk crystal.\n& + &If FALSE, ARTEMIS will generate all possible terminations.' + tag(imiller_tag)%name = 'MILLER_PLANE' tag(imiller_tag)%type = 'U' tag(imiller_tag)%summary = 'Crystal Miller plane' @@ -441,7 +485,7 @@ function setup_interface_tags() result(tag) tag(iaxis_tag)%default = '3' tag(iaxis_tag)%description = & 'NOT YET FULLY IMPLEMENTED! Defines the axis along which to print & - interfaces along.\n& + &interfaces along.\n& &NOTE: this does not change the interfaces generated, simply whether & &a generated interface will lie along a, b or c in the generated & &output structure file' @@ -495,7 +539,7 @@ function setup_interface_tags() result(tag) tag(ilw_miller_tag)%allowed = 'Three integer numbers' tag(ilw_miller_tag)%default = '(empty)' tag(ilw_miller_tag)%description = & - 'Confines the lower crystal to this Miller plane for lattice matching.\n\n& + &'Confines the lower crystal to this Miller plane for lattice matching.\n\n& &NOTE: Can only be used with IMATCH=0.\n\n& &NOTE: Miller indices used in ARTEMIS are defined for the cell in & &use. Experimental Miller indices are presented with respect to the & @@ -507,7 +551,7 @@ function setup_interface_tags() result(tag) tag(iup_miller_tag)%allowed = 'Three integer numbers' tag(iup_miller_tag)%default = '(empty)' tag(iup_miller_tag)%description = & - 'Confines the upper crystal to this Miller plane for lattice matching.\n\n& + &'Confines the upper crystal to this Miller plane for lattice matching.\n\n& &NOTE: Can only be used with IMATCH=0.\n\n& &NOTE: Miller indices used in ARTEMIS are defined for the cell in & &use. Experimental Miller indices are presented with respect to the & @@ -521,22 +565,42 @@ function setup_interface_tags() result(tag) tag(inmiller_tag)%description = & 'Defines the number of Miller planes to search over for each crystal.' - tag(ilw_thick_tag)%name = 'LW_SLAB_THICKNESS' - tag(ilw_thick_tag)%type = 'I' - tag(ilw_thick_tag)%summary = 'Thickness of lower crystal' - tag(ilw_thick_tag)%allowed = 'Any positive integer number' - tag(ilw_thick_tag)%default = '3' - tag(ilw_thick_tag)%description = & + tag(ilw_num_layers_tag)%name = 'LW_NUM_LAYERS' + tag(ilw_num_layers_tag)%type = 'I' + tag(ilw_num_layers_tag)%summary = 'Number of layers of lower crystal' + tag(ilw_num_layers_tag)%allowed = 'Any positive integer number' + tag(ilw_num_layers_tag)%default = '(empty)' + tag(ilw_num_layers_tag)%description = & 'Defines the number of primitive layers to use for the lower crystal' - tag(iup_thick_tag)%name = 'UP_SLAB_THICKNESS' - tag(iup_thick_tag)%type = 'I' - tag(iup_thick_tag)%summary = 'Thickness of upper crystal' - tag(iup_thick_tag)%allowed = 'Any positive integer number' - tag(iup_thick_tag)%default = '3' - tag(iup_thick_tag)%description = & + tag(iup_num_layers_tag)%name = 'UP_NUM_LAYERS' + tag(iup_num_layers_tag)%type = 'I' + tag(iup_num_layers_tag)%summary = 'Number of layers of upper crystal' + tag(iup_num_layers_tag)%allowed = 'Any positive integer number' + tag(iup_num_layers_tag)%default = '(empty)' + tag(iup_num_layers_tag)%description = & 'Defines the number of primitive layers to use for the upper crystal' + tag(ilw_min_thick_tag)%name = 'LW_MIN_THICKNESS' + tag(ilw_min_thick_tag)%type = 'R' + tag(ilw_min_thick_tag)%summary = 'Minimum thickness of lower crystal' + tag(ilw_min_thick_tag)%allowed = 'Any positive real number' + tag(ilw_min_thick_tag)%default = '10.0' + tag(ilw_min_thick_tag)%description = & + 'Defines the minimum thickness of the lower crystal (in Å).\n& + &The generated slab will be the smallest possible thickness equal to & + &or greater than this value.' + + tag(iup_min_thick_tag)%name = 'UP_MIN_THICKNESS' + tag(iup_min_thick_tag)%type = 'R' + tag(iup_min_thick_tag)%summary = 'Minimum thickness of upper crystal' + tag(iup_min_thick_tag)%allowed = 'Any positive real number' + tag(iup_min_thick_tag)%default = '10.0' + tag(iup_min_thick_tag)%description = & + 'Defines the minimum thickness of the upper crystal (in Å).\n& + &The generated slab will be the smallest possible thickness equal to & + &or greater than this value.' + tag(ilw_surf_tag)%name = 'LW_SURFACE' tag(ilw_surf_tag)%type = 'U' tag(ilw_surf_tag)%summary = 'Lower crystal surface terminations' @@ -584,6 +648,15 @@ function setup_interface_tags() result(tag) 'Defines the minimum size of gaps along the Miller direction that & &distinguish between separate layers (in Å) for the upper structure' + tag(ilbreak_on_no_term_tag)%name = 'LBREAK_ON_NO_TERM' + tag(ilbreak_on_no_term_tag)%type = 'L' + tag(ilbreak_on_no_term_tag)%summary = 'Stop on no termination' + tag(ilbreak_on_no_term_tag)%allowed = 'TRUE or FALSE' + tag(ilbreak_on_no_term_tag)%default = 'TRUE' + tag(ilbreak_on_no_term_tag)%description = & + 'Defines whether to stop the code if no terminations are found for a & + &given Miller plane' + tag(ilprint_shifts_tag)%name = 'LPRINT_SHIFTS' tag(ilprint_shifts_tag)%type = 'L' tag(ilprint_shifts_tag)%summary = 'Print shift information' @@ -632,7 +705,7 @@ function setup_interface_tags() result(tag) tag(imbond_maxlen_tag)%name = 'MBOND_MAXLEN' tag(imbond_maxlen_tag)%type = 'R' tag(imbond_maxlen_tag)%summary = 'Maximum considered missing bondlength' - tag(imbond_maxlen_tag)%allowed = 'Any real positive number' + tag(imbond_maxlen_tag)%allowed = 'Any positive real number' tag(imbond_maxlen_tag)%default = '4.0 (Å)' tag(imbond_maxlen_tag)%description = & 'ONLY USED IN ISHIFT = 4\n& @@ -657,7 +730,7 @@ function setup_interface_tags() result(tag) tag(iidepth_tag)%name = 'IDEPTH' tag(iidepth_tag)%type = 'I' - tag(iidepth_tag)%summary = 'Interface depth mehtod' + tag(iidepth_tag)%summary = 'Interface depth method' tag(iidepth_tag)%allowed = '0, 1' tag(iidepth_tag)%default = '0' tag(iidepth_tag)%description = & @@ -818,9 +891,9 @@ function setup_interface_tags() result(tag) &directory.\n& &Prints surfaces for crystals that have had their Miller planes supplied using the "LW_MILLER" and "UP_MILLER" tags\n& &Inside DTERMINATIONS, populates directory DLW_TERMS with lower & - parent structure surfaces.\n& + &parent structure surfaces.\n& &Inside DTERMINATIONS, populates directory DUP_TERMS with upper & - parent structure surfaces.' + &parent structure surfaces.' tag(ilortho_tag)%name = 'LORTHO' tag(ilortho_tag)%type = 'L' @@ -882,11 +955,88 @@ function setup_interface_tags() result(tag) & TRUE = fix the c axis\n& & FALSE = extend/compress c axis to compensate for strain.' + tag(ilw_require_stoich_tag)%name = 'LW_REQUIRE_STOICH' + tag(ilw_require_stoich_tag)%type = 'L' + tag(ilw_require_stoich_tag)%summary = 'Maintain stoichiometry for lower terminations' + tag(ilw_require_stoich_tag)%allowed = 'TRUE or FALSE' + tag(ilw_require_stoich_tag)%default = 'FALSE' + tag(ilw_require_stoich_tag)%description = & + 'Defines whether to maintain stoichiometry for the terminations of the lower structure.\n& + &If TRUE, ARTEMIS will only generate terminations that are consistent & + &with the stoichiometry of the bulk crystal.\n& + &If FALSE, ARTEMIS will generate all possible terminations.' + + tag(iup_require_stoich_tag)%name = 'UP_REQUIRE_STOICH' + tag(iup_require_stoich_tag)%type = 'L' + tag(iup_require_stoich_tag)%summary = 'Maintain stoichiometry for upper terminations' + tag(iup_require_stoich_tag)%allowed = 'TRUE or FALSE' + tag(iup_require_stoich_tag)%default = 'FALSE' + tag(iup_require_stoich_tag)%description = & + 'Defines whether to maintain stoichiometry for the terminations of the upper structure.\n& + &If TRUE, ARTEMIS will only generate terminations that are consistent & + &with the stoichiometry of the bulk crystal.\n& + &If FALSE, ARTEMIS will generate all possible terminations.' + end function setup_interface_tags !!!############################################################################# +!!!############################################################################# +!!! setup deprecated interface tag descriptions +!!!############################################################################# + function setup_depr_cell_edits_tags() result(tag) + implicit none + type(tag_type), dimension(ntags_depr_cell_edits) :: tag + + tag(islab_thick_tag)%name = 'SLAB_THICKNESS' + tag(islab_thick_tag)%type = 'I' + tag(islab_thick_tag)%summary = 'Number of layers of crystal' + tag(islab_thick_tag)%allowed = 'Any positive integer number' + tag(islab_thick_tag)%default = '(empty)' + tag(islab_thick_tag)%is_deprecated = .false. + tag(islab_thick_tag)%to_be_deprecated = .true. + tag(islab_thick_tag)%deprecated_version = '2.0.0' + tag(islab_thick_tag)%deprecated_name = 'NUM_LAYERS' + tag(islab_thick_tag)%description = & + 'Defines the number of primitive layers to use for the lower crystal' + + end function setup_depr_cell_edits_tags +!------------------------------------------------------------------------------- + function setup_depr_interface_tags() result(tag) + implicit none + type(tag_type), dimension(ntags_depr_interface) :: tag + + tag(ilw_slab_thick_tag)%name = 'LW_SLAB_THICKNESS' + tag(ilw_slab_thick_tag)%type = 'I' + tag(ilw_slab_thick_tag)%summary = 'Number of layers of lower crystal' + tag(ilw_slab_thick_tag)%allowed = 'Any positive integer number' + tag(ilw_slab_thick_tag)%default = '(empty)' + tag(ilw_slab_thick_tag)%is_deprecated = .false. + tag(ilw_slab_thick_tag)%to_be_deprecated = .true. + tag(ilw_slab_thick_tag)%deprecated_version = '2.0.0' + tag(ilw_slab_thick_tag)%deprecated_name = 'LW_NUM_LAYERS' + tag(ilw_slab_thick_tag)%description = & + 'Defines the number of primitive layers to use for the lower crystal' + + + tag(iup_slab_thick_tag)%name = 'UP_SLAB_THICKNESS' + tag(iup_slab_thick_tag)%type = 'I' + tag(iup_slab_thick_tag)%summary = 'Number of layers of upper crystal' + tag(iup_slab_thick_tag)%allowed = 'Any positive integer number' + tag(iup_slab_thick_tag)%default = '(empty)' + tag(iup_slab_thick_tag)%is_deprecated = .false. + tag(iup_slab_thick_tag)%to_be_deprecated = .true. + tag(iup_slab_thick_tag)%deprecated_version = '2.0.0' + tag(iup_slab_thick_tag)%deprecated_name = 'UP_NUM_LAYERS' + tag(iup_slab_thick_tag)%description = & + 'Defines the number of primitive layers to use for the upper crystal' + + end function setup_depr_interface_tags +!!!############################################################################# + + + !!!############################################################################# !!! settings card help !!!############################################################################# @@ -919,14 +1069,14 @@ subroutine cell_edits_help(unit, helpword, search) implicit none integer, intent(in) :: unit character(len=*), intent(in) :: helpword - type(tag_type), dimension(ntags_cell_edits) :: tag + type(tag_type), dimension(ntags_cell_edits + ntags_depr_cell_edits) :: tag logical :: lsearch logical, optional :: search lsearch=.false. if(present(search)) lsearch=search - tag=setup_cell_edits_tags() + tag = [ setup_cell_edits_tags(), setup_depr_cell_edits_tags() ] write(unit,'("======================================")') write(unit,'("Help information in CELL_EDITS card:")') @@ -944,14 +1094,14 @@ subroutine interface_help(unit, helpword, search) implicit none integer, intent(in) :: unit character(len=*), intent(in) :: helpword - type(tag_type), dimension(ntags_interface) :: tag + type(tag_type), dimension(ntags_interface + ntags_depr_interface) :: tag logical :: lsearch logical, optional :: search lsearch=.false. if(present(search)) lsearch=search - tag=setup_interface_tags() + tag = [ setup_interface_tags(), setup_depr_interface_tags() ] write(unit,'("======================================")') write(unit,'("Help information in INTERFACE card:")') @@ -961,6 +1111,4 @@ subroutine interface_help(unit, helpword, search) end subroutine interface_help !!!############################################################################# - - end module mod_help diff --git a/src/mod_intf_identifier.f90 b/src/fortran/lib/mod_intf_identifier.f90 similarity index 79% rename from src/mod_intf_identifier.f90 rename to src/fortran/lib/mod_intf_identifier.f90 index cc9b0f2..45d995b 100644 --- a/src/mod_intf_identifier.f90 +++ b/src/fortran/lib/mod_intf_identifier.f90 @@ -3,12 +3,13 @@ !!! Code part of the ARTEMIS group (Hepplestone research group). !!! Think Hepplestone, think HRG. !!!############################################################################# -module interface_identifier - use misc, only: swap_d,sort1D +module artemis__interface_identifier + use artemis__constants, only: real32 + use artemis__misc, only: swap,sort1D use misc_linalg, only: modu,simeq,get_area,uvec use misc_maths, only: gauss_array,get_turn_points,overlap_indiv_points,& running_avg,mean,median,mode - use rw_geom + use artemis__geom_rw implicit none private @@ -17,14 +18,14 @@ module interface_identifier type intf_info_type integer :: axis - double precision, dimension(2) :: loc + real(real32), dimension(2) :: loc end type intf_info_type type den_of_neigh_type - double precision, allocatable, dimension(:,:) :: atom + real(real32), allocatable, dimension(:,:) :: atom end type den_of_neigh_type type den_of_spec_type - double precision, allocatable, dimension(:,:,:) :: atom + real(real32), allocatable, dimension(:,:,:) :: atom end type den_of_spec_type @@ -43,32 +44,30 @@ module interface_identifier !!!############################################################################# !!! gets the interface location using CAD method !!!############################################################################# - function get_interface(lat,bas,axis) result(intf) + function get_interface(basis, axis) result(intf) implicit none + type(basis_type), intent(in) :: basis integer :: nstep - real :: dist_max - type(bas_type) :: bas + real(real32) :: dist_max type(intf_info_type) :: intf - double precision, dimension(3,3) :: lat type(den_of_spec_type), allocatable, dimension(:) :: DOS integer, optional, intent(in) :: axis - dist_max=12.0 - DOS=gen_DOS(lat,bas,dist_max) - nstep=size(DOS(1)%atom(1,1,:)) + dist_max = 12._real32 + DOS = gen_DOS(basis%lat,basis,dist_max) + nstep = size(DOS(1)%atom(1,1,:)) - if(present(axis))then - intf%axis=axis - else - intf%axis=get_intf_axis_DOS(DOS,lat,bas,dist_max) + intf%axis = 0 + if(present(axis)) intf%axis = axis + if(intf%axis.eq.0)then + intf%axis = get_intf_axis_DOS(DOS, basis%lat, basis, dist_max) end if - intf%loc=get_intf_CAD(lat,bas,intf%axis,nstep) - - if(intf%loc(1).gt.intf%loc(2)) call swap_d(intf%loc(1),intf%loc(2)) + intf%loc=get_intf_CAD(basis%lat, basis, intf%axis, nstep) + if(intf%loc(1).gt.intf%loc(2)) call swap(intf%loc(1),intf%loc(2)) end function get_interface !!!############################################################################# @@ -81,21 +80,21 @@ function gen_DOS(lat,bas,dist_max,scale_dist,norm) result(DOS) implicit none integer :: i,j,k,is,ia,js,ja,count1 integer :: nstep,nsize - real :: rdist_max,rtmp1,rtmp2 + real(real32) :: rdist_max,rtmp1,rtmp2 logical :: lscale_dist,lnorm - real :: gauss_tol,DON_sigma,dist + real(real32) :: gauss_tol,DON_sigma,dist integer, dimension(3) :: ncell - real, dimension(3) :: vrtmp1,vrtmp2 - real, dimension(3) :: vtmp1,vtmp2,vtmp3 - real, allocatable, dimension(:) :: distance + real(real32), dimension(3) :: vrtmp1,vrtmp2 + real(real32), dimension(3) :: vtmp1,vtmp2,vtmp3 + real(real32), allocatable, dimension(:) :: distance type(den_of_spec_type), allocatable, dimension(:) :: DOS - real, optional, intent(in) :: dist_max + real(real32), optional, intent(in) :: dist_max logical, optional, intent(in) :: scale_dist,norm - type(bas_type), intent(in) :: bas - double precision, dimension(3,3), intent(in) :: lat + type(basis_type), intent(in) :: bas + real(real32), dimension(3,3), intent(in) :: lat - real, allocatable, dimension(:) :: dist_list + real(real32), allocatable, dimension(:) :: dist_list if(present(scale_dist))then @@ -116,10 +115,10 @@ function gen_DOS(lat,bas,dist_max,scale_dist,norm) result(DOS) end do allocate(distance(nstep)) - rdist_max=12.D0 + rdist_max=12._real32 if(present(dist_max)) rdist_max=dist_max do i=1,nstep - distance(i)=real(i)*rdist_max/real(nstep) + distance(i)=real(i,real32)*rdist_max/real(nstep,real32) end do !! should now consider lattice vector addition for obtuse cells. @@ -154,27 +153,27 @@ function gen_DOS(lat,bas,dist_max,scale_dist,norm) result(DOS) ncell = 0 ncell_loop1: do i=1,3 - rtmp1 = real(modu(lat(i,:))) + rtmp1 = modu(lat(i,:)) ncell(i) = max(ncell(i),ceiling(rdist_max/modu(lat(i,:))))!maxval(ceiling( rdist_max/abs(lat(i,:)) )) do j=1,3 if(i.eq.j) cycle - rtmp2 = real(dot_product(lat(i,:),lat(j,:))) - if(sign(1.0,rtmp1).eq.sign(1.0,rtmp2)) cycle + rtmp2 = dot_product(lat(i,:),lat(j,:)) + if(sign(1._real32,rtmp1).eq.sign(1._real32,rtmp2)) cycle !vrtmp1 = uvec(lat(i,:)) * dot_product(uvec(lat(i,:)),lat(j,:)) !vrtmp1 = uvec(lat(i,:)) * lat(j,:) - vrtmp1 = merge(real(lat(j,:)), (/0.E0, 0.E0, 0.E0/), mask = abs(lat(i,:))>1.D-5) + vrtmp1 = merge(lat(j,:), (/0._real32, 0._real32, 0._real32/), mask = abs(lat(i,:)).gt.1.E-5_real32) rtmp1 = modu(vrtmp1) - if(abs(rtmp1).lt.1.D-5) cycle + if(abs(rtmp1).lt.1.E-5_real32) cycle k = 0 - vrtmp2 = real(lat(i,:)) + vrtmp2 = lat(i,:) rtmp2 = modu(vrtmp2) - do while ( rtmp2 <= rtmp1) + do while ( rtmp2 .le. rtmp1) k = k + 1 rtmp1 = rtmp2 - vrtmp2 = real(lat(i,:)) + real(k)*vrtmp1 + vrtmp2 = lat(i,:) + real(k,real32)*vrtmp1 rtmp2 = modu(vrtmp2) end do - if(abs(rtmp1).lt.1.D-5) cycle + if(abs(rtmp1).lt.1.E-5_real32) cycle ncell(i) = max(ncell(i), ceiling(rdist_max/rtmp1)) ncell(j) = max(ncell(j), (k-1)*ceiling(rdist_max/rtmp1)) end do @@ -192,21 +191,21 @@ function gen_DOS(lat,bas,dist_max,scale_dist,norm) result(DOS) nsize = bas%natom*(2*ncell(1)+1) * (2*ncell(2)+1) * (2*ncell(3)+1) - 1 allocate(dist_list(nsize)) - gauss_tol=16.E0!38.D0 + gauss_tol=16.E0!38._real32 DON_sigma=0.5E-1 specloop1: do is=1,bas%nspec - DOS(is)%atom(:,:,:)=0.D0 + DOS(is)%atom(:,:,:)=0._real32 atomloop1: do ia=1,bas%spec(is)%num specloop2: do js=1,bas%nspec count1=0 dist_list = 0.0 atomloop2: do ja=1,bas%spec(js)%num - vtmp1(:3) = real(bas%spec(is)%atom(ia,:3) - bas%spec(js)%atom(ja,:3)) + vtmp1(:3) = bas%spec(is)%atom(ia,:3) - bas%spec(js)%atom(ja,:3) do i=-ncell(1),ncell(1),1 - vtmp2(1) = vtmp1(1) + real(i) + vtmp2(1) = vtmp1(1) + real(i,real32) do j=-ncell(2),ncell(2),1 - vtmp2(2) = vtmp1(2) + real(j) + vtmp2(2) = vtmp1(2) + real(j,real32) kloop1: do k=-ncell(3),ncell(3),1 if(is.eq.js.and.ia.eq.ja)then if(i.eq.0.and.j.eq.0.and.k.eq.0)then @@ -220,8 +219,8 @@ function gen_DOS(lat,bas,dist_max,scale_dist,norm) result(DOS) ! write(0,'(2X,"dist_list size allocated too small")') ! stop !end if - vtmp2(3) = vtmp1(3) + real(k) - vtmp3 = matmul(vtmp2,real(lat)) + vtmp2(3) = vtmp1(3) + real(k,real32) + vtmp3 = matmul(vtmp2,lat) dist_list(count1) = modu(vtmp3) @@ -238,8 +237,8 @@ function gen_DOS(lat,bas,dist_max,scale_dist,norm) result(DOS) end do specloop2 if(lscale_dist)then - do i=minloc(abs(distance(:)-2.D0),dim=1),nstep - !dist=abs(1.D0/distance(i))**2.D0 + do i=minloc(abs(distance(:)-2._real32),dim=1),nstep + !dist=abs(1._real32/distance(i))**2._real32 dist=exp(-abs(distance(i)-2.E0)) DOS(is)%atom(ia,:,i)=DOS(is)%atom(ia,:,i)*dist end do @@ -263,10 +262,10 @@ function gen_DON(lat,bas,dist_max,scale_dist,norm) result(DON) type(den_of_spec_type), allocatable, dimension(:) :: DOS type(den_of_neigh_type), allocatable, dimension(:) :: DON - real, optional, intent(in) :: dist_max + real(real32), optional, intent(in) :: dist_max logical, optional, intent(in) :: scale_dist,norm - type(bas_type), intent(in) :: bas - double precision, dimension(3,3), intent(in) :: lat + type(basis_type), intent(in) :: bas + real(real32), dimension(3,3), intent(in) :: lat if(present(scale_dist))then @@ -310,14 +309,15 @@ function gen_DONsim(DON,dist_max,cutoff,avg_mthd) result(intf_atoms) implicit none type(den_of_neigh_type), dimension(:), intent(in) :: DON + real(real32), optional, intent(in) :: dist_max,cutoff + integer, optional, intent(in) :: avg_mthd + integer :: i,is,ia,ja,cutloc,itmp1,udef_avg_mthd integer :: nspec,natom,nstep - real :: avg,rdist_max,rcutoff,maxjump - real, optional, intent(in) :: dist_max,cutoff + real(real32) :: avg,rdist_max,rcutoff,maxjump integer, allocatable, dimension(:) :: intf_list,sumspec - real, allocatable, dimension(:) :: newf,simi,distance + real(real32), allocatable, dimension(:) :: newf,simi,distance integer, allocatable, dimension(:,:) :: intf_atoms - integer, optional, intent(in) :: avg_mthd type(den_of_neigh_type), allocatable, dimension(:) :: sim type(den_of_spec_type), allocatable, dimension(:) :: similarity @@ -328,12 +328,12 @@ function gen_DONsim(DON,dist_max,cutoff,avg_mthd) result(intf_atoms) !!!----------------------------------------------------------------------------- nstep=size(DON(1)%atom(1,:)) allocate(distance(nstep)) - rdist_max=12.D0 + rdist_max=12._real32 if(present(dist_max)) rdist_max=dist_max do i=1,nstep - distance(i)=real(i)*rdist_max/real(nstep) + distance(i)=real(i,real32)*rdist_max/real(nstep,real32) end do - rcutoff=4.D0 + rcutoff=4._real32 if(present(cutoff)) rcutoff=min(rcutoff,cutoff) cutloc=minloc(abs(distance(:)-rcutoff),dim=1) @@ -368,9 +368,9 @@ function gen_DONsim(DON,dist_max,cutoff,avg_mthd) result(intf_atoms) atomloop2: do ja=1,size(DON(is)%atom(:,1)) newf = & overlap_indiv_points(& - (real(DON(is)%atom(ia,:))),& - (real(DON(is)%atom(ja,:)))) - similarity(is)%atom(ia,ja,:)=real(newf) + [DON(is)%atom(ia,:)],& + [DON(is)%atom(ja,:)]) + similarity(is)%atom(ia,ja,:)=real(newf,real32) deallocate(newf) end do atomloop2 do i=1,nstep @@ -415,7 +415,7 @@ function gen_DONsim(DON,dist_max,cutoff,avg_mthd) result(intf_atoms) itmp1=i end do case(3) - maxjump=0.D0 + maxjump=0._real32 do i=2,natom if(simi(i)-simi(i-1).gt.maxjump)then maxjump = simi(i) - simi(i-1) @@ -450,7 +450,7 @@ end function gen_DONsim !!!############################################################################# ! subroutine get_intf_atoms(lat1,bas1,lat2,bas2) ! implicit none -! double precision, dimension(3,3) :: lat1,lat2 +! real(real32), dimension(3,3) :: lat1,lat2 ! integer, allocatable, dimension(:,:) :: intf_list1,intf_list2 ! ! @@ -469,14 +469,14 @@ function get_intf_axis_DOS(DOS,lat,bas,dist_max,cutoff,lprint) result(axis) implicit none integer :: axis integer :: i,is,ia,ja,l,m,n,ks,cutloc,nstep,itmp1 - real :: rdist_max,rcutoff,power,rtmp1 - real, optional, intent(in) :: dist_max,cutoff + real(real32) :: rdist_max,rcutoff,power,rtmp1 + real(real32), optional, intent(in) :: dist_max,cutoff logical, optional :: lprint - type(bas_type) :: bas - double precision, dimension(3) :: dir_disim - real, dimension(3) :: vtmp1,vtmp2,vtmp3 - double precision, dimension(3,3) :: lat - real, allocatable, dimension(:) :: sim_dist,distance + type(basis_type) :: bas + real(real32), dimension(3) :: dir_disim + real(real32), dimension(3) :: vtmp1,vtmp2,vtmp3 + real(real32), dimension(3,3) :: lat + real(real32), allocatable, dimension(:) :: sim_dist,distance type(den_of_spec_type), allocatable, dimension(:) :: DOS @@ -487,7 +487,7 @@ function get_intf_axis_DOS(DOS,lat,bas,dist_max,cutoff,lprint) result(axis) !!! initialise variables !!!----------------------------------------------------------------------------- if(present(lprint))then - if(lprint) write(6,'(1X,"Determining axis perpendicular to interface")') + if(lprint) write(*,'(1X,"Determining axis perpendicular to interface")') end if power=1.E0 nstep=size(DOS(1)%atom(1,1,:)) @@ -495,7 +495,7 @@ function get_intf_axis_DOS(DOS,lat,bas,dist_max,cutoff,lprint) result(axis) if(present(dist_max)) rdist_max=dist_max allocate(distance(nstep)) do i=1,nstep - distance(i)=real(i)*rdist_max/real(nstep) + distance(i)=real(i,real32)*rdist_max/real(nstep,real32) end do rcutoff=4.0 if(present(cutoff)) rcutoff=min(rcutoff,cutoff) @@ -517,23 +517,23 @@ function get_intf_axis_DOS(DOS,lat,bas,dist_max,cutoff,lprint) result(axis) distloop2: do is=1,bas%nspec do ia=1,bas%spec(is)%num itmp1=0 - sim_dist=0.D0 + sim_dist=0._real32 !!----------------------------------------------------------------- !! identifies the similarity (scaled by inverse distance) ... !! ... between an atom and each other atom of the same species. !! This shows how similar an atom is to its local environment !!----------------------------------------------------------------- do ja=1,bas%spec(is)%num - vtmp1(:3) = real(bas%spec(is)%atom(ia,:3) - & - bas%spec(is)%atom(ja,:3)) + vtmp1(:3) = bas%spec(is)%atom(ia,:3) - & + bas%spec(is)%atom(ja,:3) do l=-1,1,1 - vtmp2(1) = vtmp1(1) + real(l) + vtmp2(1) = vtmp1(1) + real(l,real32) do m=-1,1,1 - vtmp2(2) = vtmp1(2) + real(m) + vtmp2(2) = vtmp1(2) + real(m,real32) nloop3: do n=-1,1,1 - vtmp2(3) = vtmp1(3) + real(n) - vtmp3 = matmul(vtmp2,real(lat)) - !rtmp1=table_func(vtmp3(i),0.8D0) + vtmp2(3) = vtmp1(3) + real(n,real32) + vtmp3 = matmul(vtmp2,lat) + !rtmp1=table_func(vtmp3(i),0.8_real32) !rtmp1=exp(-abs(vtmp3(i))*power) rtmp1=exp(-modu(vtmp3)*power) if(rtmp1.lt.1.D-3) cycle nloop3 @@ -542,8 +542,8 @@ function get_intf_axis_DOS(DOS,lat,bas,dist_max,cutoff,lprint) result(axis) do ks=1,bas%nspec sim_dist = sim_dist + & sqrt(overlap_indiv_points(& - (real(DOS(is)%atom(ia,ks,:))),& - (real(DOS(is)%atom(ja,ks,:)))))*rtmp1 + [DOS(is)%atom(ia,ks,:)],& + [DOS(is)%atom(ja,ks,:)]))*rtmp1 end do end do nloop3 end do @@ -552,13 +552,13 @@ function get_intf_axis_DOS(DOS,lat,bas,dist_max,cutoff,lprint) result(axis) !!----------------------------------------------------------------- !! saves similarity up to the cutoff for each atom and its location !!----------------------------------------------------------------- - intf_func(i,is)%atom(ia,1)=real(bas%spec(is)%atom(ia,i)*modu(lat(i,:))) + intf_func(i,is)%atom(ia,1)=bas%spec(is)%atom(ia,i)*modu(lat(i,:)) intf_func(i,is)%atom(ia,2)=sum(sim_dist(:cutloc))!/bas%spec(is)%num!/itmp1 end do end do distloop2 - dir_disim(i)=0.D0 + dir_disim(i)=0._real32 !!----------------------------------------------------------------------- !! finds max difference between points within the cell along a direction !!----------------------------------------------------------------------- @@ -567,7 +567,7 @@ function get_intf_axis_DOS(DOS,lat,bas,dist_max,cutoff,lprint) result(axis) do ja=ia+1,bas%spec(is)%num if( abs( & intf_func(i,is)%atom(ia,1) - & - intf_func(i,is)%atom(ja,1)).lt.1.D0)then + intf_func(i,is)%atom(ja,1)).lt.1._real32)then if( abs( & intf_func(i,is)%atom(ia,2) - & intf_func(i,is)%atom(ja,2)).gt.dir_disim(i) )then @@ -589,7 +589,7 @@ function get_intf_axis_DOS(DOS,lat,bas,dist_max,cutoff,lprint) result(axis) !!!----------------------------------------------------------------------------- axis=minloc(dir_disim,dim=1) if(present(lprint))then - if(lprint) write(6,*) "Interface located along axis",axis + if(lprint) write(*,*) "Interface located along axis",axis end if @@ -604,17 +604,17 @@ function get_intf_axis_CAD(lat,bas) result(axis) implicit none integer :: i,j,is,iaxis integer :: pntl,pntr,nstep - double precision :: sigma,gauss_tol,area + real(real32) :: sigma,gauss_tol,area integer, dimension(3) :: abc - double precision, dimension(3) :: vtmp1,vtmp2,axis_vec - real, allocatable, dimension(:) :: rangevec - double precision, allocatable, dimension(:) :: dist,multiCADD - double precision, allocatable, dimension(:,:) :: CAD,deriv - double precision, allocatable, dimension(:,:,:) :: CADD + real(real32), dimension(3) :: vtmp1,vtmp2,axis_vec + real(real32), allocatable, dimension(:) :: rangevec + real(real32), allocatable, dimension(:) :: dist,multiCADD + real(real32), allocatable, dimension(:,:) :: CAD,deriv + real(real32), allocatable, dimension(:,:,:) :: CADD integer :: axis - type(bas_type), intent(in) :: bas - double precision, dimension(3,3), intent(in) :: lat + type(basis_type), intent(in) :: bas + real(real32), dimension(3,3), intent(in) :: lat @@ -623,10 +623,10 @@ function get_intf_axis_CAD(lat,bas) result(axis) !!!----------------------------------------------------------------------------- nstep=nstep_default allocate(dist(nstep)) - dist=0.D0 + dist=0._real32 - sigma=2.D0 - gauss_tol=16.D0 + sigma=2._real32 + gauss_tol=16._real32 allocate(rangevec(bas%nspec)) allocate(deriv(bas%nspec,nstep)) allocate(CAD(bas%nspec,nstep)) @@ -643,8 +643,8 @@ function get_intf_axis_CAD(lat,bas) result(axis) end do abc = cshift(abc,1,1) area = get_area(lat(abc(1),:),lat(abc(2),:)) - CAD=0.D0 - CADD=0.D0 + CAD=0._real32 + CADD=0._real32 !!-------------------------------------------------------------------------- !! set up CAD and CADD !!-------------------------------------------------------------------------- @@ -655,7 +655,7 @@ function get_intf_axis_CAD(lat,bas) result(axis) do j=-1,1,1 CAD(is,:) = CAD(is,:) + gauss_array(& dist(:),& - (bas%spec(is)%atom(:,iaxis)+dble(j))*modu(lat(iaxis,:)),& + (bas%spec(is)%atom(:,iaxis)+real(j,real32))*modu(lat(iaxis,:)),& sigma,gauss_tol,.false.) end do !!----------------------------------------------------------------------- @@ -671,12 +671,12 @@ function get_intf_axis_CAD(lat,bas) result(axis) pntl=i-1 pntr=i+1 do j=-1,1,1 - vtmp1(j+2)=dble(i+j-1)*modu(lat(iaxis,:))/nstep + vtmp1(j+2)=real(i+j-1,real32)*modu(lat(iaxis,:))/nstep end do - vtmp2=0.D0 + vtmp2=0._real32 vtmp2(2)=CAD(is,i) if(i.eq.1)then - vtmp2(1)=0.D0 + vtmp2(1)=0._real32 vtmp2(3)=CAD(is,pntr) !pntl=nstep-1 elseif(i.eq.nstep)then @@ -698,7 +698,7 @@ function get_intf_axis_CAD(lat,bas) result(axis) !!-------------------------------------------------------------------------- !! multiply the CADDs of each species into an overal CADD (multiCADD) !!-------------------------------------------------------------------------- - multiCADD=1.D0 + multiCADD=1._real32 do is=1,bas%nspec if(rangevec(is).lt.maxval(rangevec)*5.D-2) cycle multiCADD(:) = multiCADD(:)*CADD(is,:,1) @@ -729,17 +729,18 @@ function get_intf_CAD(lat,bas,axis,num_step,lprint) result(intf_loc) integer :: i,j,is integer :: pntl,pntr,nstep integer, optional, intent(in) :: num_step - type(bas_type) :: bas - double precision :: sigma, gauss_tol - double precision, dimension(2) :: intf_loc - double precision, dimension(3) :: vtmp1,vtmp2 - double precision, dimension(3,3) :: lat + type(basis_type) :: bas + real(real32) :: sigma, gauss_tol + real(real32), dimension(2) :: intf_loc + real(real32), dimension(3) :: vtmp1,vtmp2 + real(real32), dimension(3,3) :: lat integer, allocatable, dimension(:) :: ivec1 - real, allocatable, dimension(:) :: rangevec - double precision, allocatable, dimension(:) :: dist,multiCADD - double precision, allocatable, dimension(:,:) :: CAD,deriv - double precision, allocatable, dimension(:,:,:) :: CADD + real(real32), allocatable, dimension(:) :: rangevec + real(real32), allocatable, dimension(:) :: dist,multiCADD + real(real32), allocatable, dimension(:,:) :: CAD,deriv + real(real32), allocatable, dimension(:,:,:) :: CADD logical, optional :: lprint + real(real32) :: diff !!!----------------------------------------------------------------------------- @@ -748,19 +749,19 @@ function get_intf_CAD(lat,bas,axis,num_step,lprint) result(intf_loc) nstep=nstep_default if(present(num_step)) nstep=num_step allocate(dist(nstep)) - dist=0.D0 + dist=0._real32 do i=1,nstep dist(i)=(i-1)*modu(lat(axis,:))/nstep end do - sigma=2.D0 - gauss_tol=16.D0 + sigma=2._real32 + gauss_tol=16._real32 allocate(rangevec(bas%nspec)) allocate(deriv(bas%nspec,nstep)) allocate(CAD(bas%nspec,nstep)) allocate(CADD(bas%nspec,nstep,3)) !!CADD(spec,nstep,nth order deriv) - CAD=0.D0 - CADD=0.D0 + CAD=0._real32 + CADD=0._real32 !!!----------------------------------------------------------------------------- @@ -773,7 +774,7 @@ function get_intf_CAD(lat,bas,axis,num_step,lprint) result(intf_loc) do j=-1,1,1 CAD(is,:) = CAD(is,:) + gauss_array(& dist(:),& - (bas%spec(is)%atom(:,axis)+dble(j))*modu(lat(axis,:)),& + (bas%spec(is)%atom(:,axis)+real(j,real32))*modu(lat(axis,:)),& sigma,gauss_tol,.false.) end do !!----------------------------------------------------------------------- @@ -789,12 +790,12 @@ function get_intf_CAD(lat,bas,axis,num_step,lprint) result(intf_loc) pntl=i-1 pntr=i+1 do j=-1,1,1 - vtmp1(j+2)=dble(i+j-1)*modu(lat(axis,:))/nstep + vtmp1(j+2)=real(i+j-1,real32)*modu(lat(axis,:))/nstep end do - vtmp2=0.D0 + vtmp2=0._real32 vtmp2(2)=CAD(is,i) if(i.eq.1)then - vtmp2(1)=0.D0 + vtmp2(1)=0._real32 vtmp2(3)=CAD(is,pntr) !pntl=nstep-1 elseif(i.eq.nstep)then @@ -817,7 +818,7 @@ function get_intf_CAD(lat,bas,axis,num_step,lprint) result(intf_loc) !!! multiply the CADDs of each species into an overal CADD (multiCADD) !!!----------------------------------------------------------------------------- allocate(multiCADD(nstep)) - multiCADD=1.D0 + multiCADD=1._real32 do is=1,bas%nspec if(rangevec(is).lt.maxval(rangevec)*5.D-2) cycle multiCADD(:)=multiCADD(:)*CADD(is,:,1) @@ -828,9 +829,9 @@ function get_intf_CAD(lat,bas,axis,num_step,lprint) result(intf_loc) !!! identify whether system is likely a planar defect !!!----------------------------------------------------------------------------- if(count(abs(multiCADD).lt.1.D-8).gt.0.9*nstep)then - write(6,'(1X,"System has same species-split density across system")') - write(6,'(1X,"Likely a planar defect")') - write(6,'(1X,"Use another interface identifier method...")') + write(*,'(1X,"System has same species-split density across system")') + write(*,'(1X,"Likely a planar defect")') + write(*,'(1X,"Use another interface identifier method...")') end if @@ -852,10 +853,20 @@ function get_intf_CAD(lat,bas,axis,num_step,lprint) result(intf_loc) !!! finds the turning points of the multiCADD and attributes them to ... !!! ... the two interfaces !!!----------------------------------------------------------------------------- - ivec1=get_turn_points(dble(multiCADD(:)),window=8,lperiodic=.true.) - intf_loc(1)=dist(ivec1(size(ivec1))) - intf_loc(2)=dist(ivec1(size(ivec1)-1)) + ivec1 = get_turn_points([multiCADD(:)],window=8,lperiodic=.true.) + intf_loc(1)=dist(ivec1(size(ivec1))) + do i = size(ivec1) - 1, 1, -1 + diff = abs(intf_loc(1)-dist(ivec1(i))) + ! map back into the original space if greater than the size of the cell + if(abs(diff).gt.0.5*modu(lat(axis,:)))then + diff = diff - sign(1._real32,diff) * modu(lat(axis,:)) + end if + if(abs(diff).gt.2._real32)then + intf_loc(2)=dist(ivec1(i)) + exit + end if + end do end function get_intf_CAD @@ -869,22 +880,22 @@ function get_layered_axis(lat,bas,lprint) result(axis) implicit none integer :: i,is,j,nstep,diffcount,axis !integer, dimension(3) :: nturns - double precision :: sigma, gauss_tol + real(real32) :: sigma, gauss_tol logical :: udef_lprint - double precision, dimension(3) :: diff - double precision, dimension(3,2) :: minmax - double precision, allocatable, dimension(:) :: AD,dist + real(real32), dimension(3) :: diff + real(real32), dimension(3,2) :: minmax + real(real32), allocatable, dimension(:) :: AD,dist !integer, allocatable, dimension(:) :: ivec1 - type(bas_type), intent(in) :: bas - double precision, dimension(3,3), intent(in) :: lat + type(basis_type), intent(in) :: bas + real(real32), dimension(3,3), intent(in) :: lat logical, optional, intent(in) :: lprint !!!----------------------------------------------------------------------------- !!! initialise variables !!!----------------------------------------------------------------------------- - sigma=0.5D0 - gauss_tol=16.D0 + sigma=0.5_real32 + gauss_tol=16._real32 if(present(lprint))then udef_lprint=lprint else @@ -897,21 +908,21 @@ function get_layered_axis(lat,bas,lprint) result(axis) !!!----------------------------------------------------------------------------- axis_loop1: do i=1,3 if(allocated(dist)) deallocate(dist) - nstep=nint(modu(lat(i,:))/0.001D0) + nstep=nint(modu(lat(i,:))/0.001_real32) allocate(dist(nstep)) - dist=0.D0 + dist=0._real32 do j=1,nstep dist(j)=(j-1)*modu(lat(i,:))/nstep end do if(allocated(AD)) deallocate(AD) allocate(AD(nstep)) - AD=0.D0 + AD=0._real32 do is=1,bas%nspec do j=-1,1,1 AD(:) = AD(:) + gauss_array(& dist(:),& - (bas%spec(is)%atom(:,i)+dble(j))*modu(lat(i,:)),& + (bas%spec(is)%atom(:,i)+real(j,real32))*modu(lat(i,:)),& sigma,gauss_tol,.false.) end do end do @@ -927,7 +938,7 @@ function get_layered_axis(lat,bas,lprint) result(axis) !!! checks each axis !!!----------------------------------------------------------------------------- axis=0 - select case(count(diff.gt.huge(0.D0))) + select case(count(diff.gt.huge(0._real32))) case(1) axis=maxloc(diff(:),dim=1) if(udef_lprint) write(0,'("Found a 2D system along ",I0)') axis @@ -941,7 +952,7 @@ function get_layered_axis(lat,bas,lprint) result(axis) case default axis_loop2: do i=1,3 !!! ADD A TOLERANCE FOR 'COULD BE LAYERED' - diffcount=count(diff(i).gt.5.D0*diff(:)) + diffcount=count(diff(i).gt.5._real32*diff(:)) if(diffcount.eq.2)then axis=i exit axis_loop2 @@ -967,11 +978,11 @@ end function get_layered_axis ! function locate_two_intfs(func,ivec1,lmax) result(intf_loc) ! implicit none ! integer :: loc,i -! real :: rtmp1 +! real(real32) :: rtmp1 ! logical :: luse_max ! integer, dimension (:) :: ivec1 ! integer, dimension(2) :: intf_loc -! real, dimension(:) :: func +! real(real32), dimension(:) :: func ! logical, optional :: lmax ! ! @@ -1011,20 +1022,20 @@ function gen_single_DOS(lat,bas,ispec,iatom,dist_max,weight_dist) result(DOS) implicit none integer :: i,j,k,js,ja,count1 integer :: nstep - real :: rdist_max - real :: gauss_tol,DON_sigma,dist,dist_cutoff,rtmp1 - type(bas_type) :: bas + real(real32) :: rdist_max + real(real32) :: gauss_tol,DON_sigma,dist,dist_cutoff,rtmp1 + type(basis_type) :: bas logical :: lweight - real, dimension(3) :: vtmp1,vtmp2,vtmp3 - real, allocatable, dimension(:) :: distance + real(real32), dimension(3) :: vtmp1,vtmp2,vtmp3 + real(real32), allocatable, dimension(:) :: distance integer, intent(in) :: ispec,iatom - double precision, dimension(3,3), intent(in) :: lat - real, optional, intent(in) :: dist_max + real(real32), dimension(3,3), intent(in) :: lat + real(real32), optional, intent(in) :: dist_max logical, optional, intent(in) :: weight_dist - double precision, allocatable, dimension(:,:) :: DOS + real(real32), allocatable, dimension(:,:) :: DOS - real, allocatable, dimension(:) :: dist_list + real(real32), allocatable, dimension(:) :: dist_list nstep=nstep_default @@ -1032,34 +1043,34 @@ function gen_single_DOS(lat,bas,ispec,iatom,dist_max,weight_dist) result(DOS) allocate(DOS(bas%nspec,nstep)) allocate(distance(nstep)) - rdist_max=12.D0 + rdist_max=12._real32 if(present(dist_max)) rdist_max=dist_max do i=1,nstep - distance(i)=real(i)*rdist_max/real(nstep) + distance(i)=real(i,real32)*rdist_max/real(nstep,real32) end do - gauss_tol=16.E0!38.D0 + gauss_tol=16.E0!38._real32 DON_sigma=0.5E-1 dist_cutoff=dist_max+sqrt(2*gauss_tol*DON_sigma**2) - DOS(:,:)=0.D0 + DOS(:,:)=0._real32 specloop1: do js=1,bas%nspec count1=0 dist_list = 0.0 atomloop1: do ja=1,bas%spec(js)%num - vtmp1(:3) = real(bas%spec(ispec)%atom(iatom,:3) - bas%spec(js)%atom(ja,:3)) + vtmp1(:3) = bas%spec(ispec)%atom(iatom,:3) - bas%spec(js)%atom(ja,:3) do i=-1,1,1 - vtmp2(1) = vtmp1(1) + real(i) + vtmp2(1) = vtmp1(1) + real(i,real32) do j=-1,1,1 - vtmp2(2) = vtmp1(2) + real(j) + vtmp2(2) = vtmp1(2) + real(j,real32) kloop1: do k=-1,1,1 if(ispec.eq.js.and.iatom.eq.ja)then if(i.eq.0.and.j.eq.0.and.k.eq.0)then cycle kloop1 end if end if - vtmp2(3) = vtmp1(3) + real(k) - vtmp3 = matmul(vtmp2,real(lat)) + vtmp2(3) = vtmp1(3) + real(k,real32) + vtmp3 = matmul(vtmp2,lat) rtmp1=modu(vtmp3) if(rtmp1.gt.dist_cutoff) cycle kloop1 count1=count1+1 @@ -1101,12 +1112,12 @@ end function gen_single_DOS function gen_single_DON(lat,bas,ispec,iatom,dist_max) result(DON) implicit none integer :: i,nstep - type(bas_type) :: bas - double precision, dimension(3,3) :: lat - double precision, allocatable, dimension(:) :: DON - double precision, allocatable, dimension(:,:) :: DOS + type(basis_type) :: bas + real(real32), dimension(3,3) :: lat + real(real32), allocatable, dimension(:) :: DON + real(real32), allocatable, dimension(:,:) :: DOS integer, intent(in) :: ispec,iatom - real, optional, intent(in) :: dist_max + real(real32), optional, intent(in) :: dist_max if(present(dist_max))then @@ -1126,4 +1137,4 @@ end function gen_single_DON !!!############################################################################# -end module interface_identifier +end module artemis__interface_identifier diff --git a/src/io.F90 b/src/fortran/lib/mod_io_utils.F90 similarity index 73% rename from src/io.F90 rename to src/fortran/lib/mod_io_utils.F90 index 83abf44..8518226 100644 --- a/src/io.F90 +++ b/src/fortran/lib/mod_io_utils.F90 @@ -4,13 +4,24 @@ !!! Ned Thaddeus Taylor !!! Code part of the ARTEMIS group !!!############################################################################# -module io - use misc +module artemis__io_utils + use artemis__constants, only: real32 + use artemis__misc implicit none - private !everything is private unless explicitly defined as public - character(25), public, parameter :: version="development version 1.0.3a" + private + + public :: write_fmtd + public :: err_abort,print_warning, stop_program + public :: io_print_help + public :: print_header + public :: artemis__version__ + + + logical :: test_error_handling = .false. + logical :: suppress_warnings = .false. + character(len=*), parameter :: artemis__version__ = "2.0.0" !character(30), public, parameter :: & ! author(3) = [& ! "N. T. Taylor",& @@ -27,28 +38,56 @@ module io ! "S. G. Davies"& ! ] - + type, public :: tag_type character(25) :: name character(1) :: type - character(40) :: summary + character(50) :: summary character(60) :: allowed character(60) :: default character(1024) :: description + logical :: is_deprecated = .false. + logical :: to_be_deprecated = .false. + character(25) :: deprecated_name = '' + character(20) :: deprecated_version end type tag_type - public :: write_fmtd - public :: err_abort,print_warning - public :: err_abort_print_struc - public :: io_print_help - public :: print_header - public :: setup_input_fmt,setup_output_fmt -!!!updated 2021/11/11 +contains + +!############################################################################### + subroutine stop_program(message, exit_code, block_stop) + !! Stop the program and print an error message. + implicit none + character(len=*), intent(in) :: message + integer, intent(in), optional :: exit_code + logical, intent(in), optional :: block_stop + + integer :: exit_code_ + logical :: block_stop_ + + if(present(exit_code)) then + exit_code_ = exit_code + else + exit_code_ = 1 + end if + if(present(block_stop)) then + block_stop_ = block_stop + else + block_stop_ = .false. + end if + + write(0,*) 'ERROR: ', trim(message) + if(.not.block_stop_)then + if(.not.test_error_handling) then + stop exit_code_ + end if + end if + end subroutine stop_program +!############################################################################### -contains !!!############################################################################# !!! prints the ARTEMIS logo and author list !!!############################################################################# @@ -72,7 +111,7 @@ subroutine print_header(unit) write(unit,'(A)') " Ab Initio Restructuring Tool " write(unit,'(A)') " Enabling Modelling of Interface Structures " write(unit,*) - write(unit,'(A,A)') " Welcome to ARTEMIS version ",version + write(unit,'(A,A)') " Welcome to ARTEMIS version ", artemis__version__ write(unit,'(A,A,1X,A,A)') " (build ",__DATE__,__TIME__,")" write(unit,*) write(unit,'(A)') " Authors:" @@ -86,11 +125,10 @@ subroutine print_header(unit) write(unit,'(A)') " Artistic advisors:" write(unit,'(A)') " E. L. Martin" write(unit,*) - write(unit,'(A)') " LICENCE:" + write(unit,'(A)') " LICENSE:" write(unit,'(A)') " This work is licensed under a & - &Creative Commons Attribution-NonCommercial 3.0 & - &Unported (CC BY-NC 3.0) License." - write(unit,'(A)') " https://creativecommons.org/licenses/by-nc/3.0/" + &General Public License 3.0 (GPLv3)" + write(unit,'(A)') " https://www.gnu.org/licenses/gpl-3.0.en.html" write(unit,*) write(unit,'(A)') repeat("#",50) @@ -240,7 +278,7 @@ subroutine err_abort(message,fmtd) lpresent=.false. if(present(fmtd))then if(fmtd)then - call write_fmtd(unit,trim(message)) + call write_fmtd(unit,"ERROR: "//trim(message)) lpresent=.true. end if end if @@ -251,28 +289,6 @@ end subroutine err_abort !!!############################################################################# -!!!############################################################################# -!!! Prints to stderr, prints structure and stops -!!!############################################################################# - subroutine err_abort_print_struc(in_lat,in_bas,name,message,lstop) - use rw_geom - implicit none - integer :: unit=0 - character(len=*) :: name,message - type(bas_type) :: in_bas - double precision, dimension(3,3) :: in_lat - logical, optional :: lstop - - - open(100,file=name) - call geom_write(100,in_lat,in_bas) - close(100) - if(message.ne.'') write(unit,'(A)') trim(message) - if(.not.present(lstop).or.lstop) stop - - end subroutine err_abort_print_struc -!!!############################################################################# - !!!############################################################################# !!! help and search @@ -314,8 +330,18 @@ subroutine io_print_help(unit, helpword, tags, search) if(index(tags(i)%name,checkword).ne.0)then found=.true. - write(unit,'(A,T33,A)') & - trim(tags(i)%name),trim(tags(i)%summary) + if(tags(i)%to_be_deprecated)then + write(unit,'(A,T33,A)') & + trim(tags(i)%name),& + 'To be deprecated ('//trim(tags(i)%deprecated_version)//')' + elseif(tags(i)%is_deprecated)then + write(unit,'(A,T33,A)') & + trim(tags(i)%name),& + 'Deprecated ('//trim(tags(i)%deprecated_version)//')' + else + write(unit,'(A,T33,A)') & + trim(tags(i)%name),trim(tags(i)%summary) + end if end if end do tagloop1 @@ -355,6 +381,19 @@ subroutine io_print_help(unit, helpword, tags, search) write(unit,*) write(unit,fmt) trim(title) write(unit,*) + if(tags(i)%is_deprecated)then + write(unit,'("DEPRECATED AS OF ",A)') & + trim(tags(i)%deprecated_version) + elseif(tags(i)%to_be_deprecated)then + write(unit,'("TO BE DEPRECATED AS OF ",A)') & + trim(tags(i)%deprecated_version) + end if + if(trim(tags(i)%deprecated_name).ne.'')then + write(unit,'("New tag name: ",A)') trim(tags(i)%deprecated_name) + end if + if(tags(i)%is_deprecated.or.tags(i)%to_be_deprecated)then + write(unit,*) + end if select case(tags(i)%type) case('I'); type = 'Integer' @@ -386,82 +425,5 @@ subroutine io_print_help(unit, helpword, tags, search) end subroutine io_print_help !!!############################################################################# - - -!!!############################################################################# -!!! sets up the name of output files and subroutines to read files -!!!############################################################################# - subroutine setup_input_fmt(fmt) - use rw_geom, only : igeom_input - implicit none - character(len=*), intent(in) :: fmt - character(len=:), allocatable :: form - - - allocate(character(len=len(trim(adjustl(fmt)))) :: form) - form = trim(adjustl(to_upper(fmt))) - - select case(form) - case("VASP") - write(6,*) "Input files will be VASP formatted" - igeom_input=1 - case("CASTEP") - write(6,*) "Input files will be CASTEP formatted" - igeom_input=2 - !call err_abort('ERROR: ARTEMIS not yet set up for CASTEP') - case("QE","QUANTUMESPRESSO") - write(6,*) "Input files will be QuantumEspresso formatted" - igeom_input=3 - !call err_abort('ERROR: ARTEMIS not yet set up for Quantum Espresso') - case("CRYSTAL") - write(6,*) "Input files will be CRYSTAL formatted" - igeom_input=4 - call err_abort('ERROR: ARTEMIS not yet set up for CRYSTAL') - end select - - - end subroutine setup_input_fmt -!!!############################################################################# - - -!!!############################################################################# -!!! sets up the name of output files and subroutines to read files -!!!############################################################################# - subroutine setup_output_fmt(fmt,out_filename) - use rw_geom, only : igeom_output - implicit none - character(len=*) :: out_filename - character(len=*), intent(in) :: fmt - character(len=:), allocatable :: form - - - allocate(character(len=len(trim(adjustl(fmt)))) :: form) - form = trim(adjustl(to_upper(fmt))) - - select case(form) - case("VASP") - write(6,*) "Output files will be VASP formatted" - if(out_filename.eq.'') out_filename="POSCAR" - igeom_output=1 - case("CASTEP") - write(6,*) "Output files will be CASTEP formatted" - if(out_filename.eq.'') out_filename="struc.cell" - igeom_output=2 - !call err_abort('ERROR: ARTEMIS not yet set up for CASTEP') - case("QE","QUANTUMESPRESSO") - write(6,*) "Output files will be QuantumEspresso formatted" - if(out_filename.eq.'') out_filename="struc.geom" - igeom_output=3 - !call err_abort('ERROR: ARTEMIS not yet set up for Quantum Espresso') - case("CRYSTAL") - write(6,*) "Output files will be CRYSTAL formatted" - if(out_filename.eq.'') out_filename="INPUT_geom" - igeom_output=4 - call err_abort('ERROR: ARTEMIS not yet set up for CRYSTAL') - end select - - - end subroutine setup_output_fmt -!!!############################################################################# -end module io +end module artemis__io_utils diff --git a/src/fortran/lib/mod_io_utils_extd.F90 b/src/fortran/lib/mod_io_utils_extd.F90 new file mode 100644 index 0000000..3582f69 --- /dev/null +++ b/src/fortran/lib/mod_io_utils_extd.F90 @@ -0,0 +1,134 @@ +module artemis__io_utils_extd + use artemis__misc, only: to_upper + use artemis__io_utils, only: err_abort + + private + + public :: err_abort_print_struc + public :: setup_input_fmt, setup_output_fmt + + + +contains + +!############################################################################### + subroutine err_abort_print_struc(basis,filename,msg,lstop) + !! Print structure to file and stops + use artemis__geom_rw, only: basis_type, geom_write + implicit none + + ! Arguments + type(basis_type), intent(in) :: basis + !! Structure to print + character(len=*), intent(in) :: filename + !! File name to print to + character(len=*), intent(in) :: msg + !! Message to print + logical, intent(in), optional :: lstop + !! Boolean whether to stop or not + + ! Local variables + integer :: unit + !! File unit + + + open(newunit=unit,file=filename) + call geom_write(unit, basis) + close(unit) + if(msg.ne.'') write(0,'(A)') trim(msg) + if(present(lstop))then + if(lstop) stop + else + stop + end if + + end subroutine err_abort_print_struc +!############################################################################### + + +!############################################################################### + subroutine setup_input_fmt(fmt) + !! Set the structure file input format for the program + use artemis__geom_rw, only : igeom_input + implicit none + + ! Arguments + character(len=*), intent(in) :: fmt + !! Format of the input file + + ! Local variables + character(len=:), allocatable :: form + !! Formatted string for the input file + + + allocate(character(len=len(trim(adjustl(fmt)))) :: form) + form = trim(adjustl(to_upper(fmt))) + + select case(form) + case("VASP") + write(*,*) "Input files will be VASP formatted" + igeom_input=1 + case("CASTEP") + write(*,*) "Input files will be CASTEP formatted" + igeom_input=2 + !call err_abort('ERROR: ARTEMIS not yet set up for CASTEP') + case("QE","QUANTUMESPRESSO") + write(*,*) "Input files will be QuantumEspresso formatted" + igeom_input=3 + !call err_abort('ERROR: ARTEMIS not yet set up for Quantum Espresso') + case("CRYSTAL") + write(*,*) "Input files will be CRYSTAL formatted" + igeom_input=4 + call err_abort('ERROR: ARTEMIS not yet set up for CRYSTAL') + end select + + end subroutine setup_input_fmt +!############################################################################### + + +!############################################################################### + subroutine setup_output_fmt(fmt,out_filename) + !! Set the structure file input format for the program + use artemis__geom_rw, only : igeom_output + implicit none + + ! Arguments + character(len=*), intent(in) :: fmt + !! Format of the output file + character(len=*), intent(inout) :: out_filename + !! File name to print to + + ! Local variables + character(len=:), allocatable :: form + !! Formatted string for the output file + + + allocate(character(len=len(trim(adjustl(fmt)))) :: form) + form = trim(adjustl(to_upper(fmt))) + + select case(form) + case("VASP") + write(*,*) "Output files will be VASP formatted" + if(out_filename.eq.'') out_filename="POSCAR" + igeom_output=1 + case("CASTEP") + write(*,*) "Output files will be CASTEP formatted" + if(out_filename.eq.'') out_filename="struc.cell" + igeom_output=2 + !call err_abort('ERROR: ARTEMIS not yet set up for CASTEP') + case("QE","QUANTUMESPRESSO") + write(*,*) "Output files will be QuantumEspresso formatted" + if(out_filename.eq.'') out_filename="struc.geom" + igeom_output=3 + !call err_abort('ERROR: ARTEMIS not yet set up for Quantum Espresso') + case("CRYSTAL") + write(*,*) "Output files will be CRYSTAL formatted" + if(out_filename.eq.'') out_filename="INPUT_geom" + igeom_output=4 + call err_abort('ERROR: ARTEMIS not yet set up for CRYSTAL') + end select + + end subroutine setup_output_fmt +!############################################################################### + +end module artemis__io_utils_extd \ No newline at end of file diff --git a/src/mod_lat_compare.f90 b/src/fortran/lib/mod_lat_compare.f90 similarity index 66% rename from src/mod_lat_compare.f90 rename to src/fortran/lib/mod_lat_compare.f90 index 3aa477b..6153635 100644 --- a/src/mod_lat_compare.f90 +++ b/src/fortran/lib/mod_lat_compare.f90 @@ -14,153 +14,23 @@ !!! convert_n_tf1!!! endcode !!!############################################################################# module lat_compare - use constants + use artemis__constants, only: real32, pi, INF + use artemis__misc_types, only: latmatch_type, tol_type use misc_linalg, only: cross,uvec,modu,get_area,find_tf,det,reduce_vec_gcd,& inverse_3x3,get_vec_multiple,get_frac_denom - use rw_geom, only: bas_type - use edit_geom, only: MATNORM,planecutter + use artemis__geom_rw, only: basis_type + use artemis__geom_utils, only: MATNORM,planecutter implicit none - integer :: ierr_compare + integer :: ierr_compare = 0 logical :: lstop=.true. - logical :: lreduce=.true. - integer, private :: match_method=0 - - type latmatch_type - integer :: nfit - logical :: lreduced - character(1) :: abc(3)=(/'a','b','c'/) - - integer, dimension(2) :: axes - integer, allocatable, dimension(:,:,:) :: tf1,tf2 - double precision, allocatable, dimension(:,:) :: tol - double precision, dimension(3,3) :: lat1,lat2 - end type latmatch_type - - type tol_type - integer :: maxsize,maxfit,nstore - double precision :: maxlen=20.D0 - double precision :: maxarea=400.D0 - double precision :: vec,ang,area - double precision :: ang_weight = 10.D0 - double precision :: area_weight = 100.D0 - end type tol_type + logical :: reduce=.false. + !!!updated 2021/11/19 contains -!!!############################################################################# -!!! -!!!############################################################################# - function get_best_match(tol,lat1,lat2,bas1,bas2,str1,str2,lprint,ierr,plane1,plane2,nmiller,imatch) result(SAV) - implicit none - integer :: num_miller - character(3) :: str1,str2 - logical :: lprint - type(tol_type) :: tol - type(bas_type) :: bas1,bas2 - type(latmatch_type) :: SAV - double precision, dimension(3,3) :: lat1,lat2 - integer, optional :: ierr,imatch,nmiller - integer, dimension(3), optional :: plane1,plane2 - - if(present(imatch)) match_method=imatch - if(present(ierr))then - ierr_compare=ierr - else - ierr_compare=0 - end if - num_miller=10 - if(present(nmiller)) num_miller=nmiller - - allocate(SAV%tf1(tol%nstore,3,3)) - allocate(SAV%tf2(tol%nstore,3,3)) - allocate(SAV%tol(tol%nstore,3)) - - SAV%tol(:,:)=10000 - SAV%lat1=MATNORM(lat1) - SAV%lat2=MATNORM(lat2) - - if(match_method.eq.0)then - if(present(plane1))then - if(present(plane2))then - call lattice_matching(& - SAV,tol,bas1,bas2,& - plane1=plane1,plane2=plane2,nmiller=num_miller,& - lprint=lprint) - else - call lattice_matching(& - SAV,tol,bas1,bas2,& - plane1=plane1,nmiller=num_miller,& - lprint=lprint) - end if - elseif(present(plane2))then - call lattice_matching(& - SAV,tol,bas1,bas2,& - plane2=plane2,nmiller=num_miller,& - lprint=lprint) - else - call lattice_matching(& - SAV,tol,bas1,bas2,& - plane2=plane2,nmiller=num_miller,& - lprint=lprint) - end if - else - call pick_axis(SAV,(/str1,str2/),lprint) - call cyc_lat1(SAV,tol,lprint) - end if - if(lprint) call endcode(SAV) -! if(any(isnan(SAV%tf1(:,:,:))).or.any(isnan(SAV%tf2(:,:,:))))then -! write(0,*) "CODE BROKE ON FINDING A MATCH (NaN)" -! write(0,*) "Exiting..." -! call exit() -! end if - - - return - end function get_best_match -!!!############################################################################# - - -!!!############################################################################# -!!! Axis picker -!!!############################################################################# - subroutine pick_axis(SAV,str,lprint) - implicit none - integer :: i - logical :: lprint - character(3), dimension(2) :: str - type(latmatch_type) :: SAV - - - do i=1,2 - if(verify("abc",str(i)).eq.0) then - SAV%axes(i)=3 - if(lprint) write(6,*) "Finding matches of all possible planes." - elseif(verify("abc",str(i)).eq.3) then - SAV%axes(i)=2 - if(lprint) write(6,*) "Finding matches of the ab planes." - elseif(verify("abc",str(i)).eq.1) then - SAV%axes(i)=2 - SAV%abc=cshift(SAV%abc,shift=1) - SAV%lat1(:,:)=cshift(SAV%lat1(:,:),shift=1,dim=1) - SAV%lat2(:,:)=cshift(SAV%lat2(:,:),shift=1,dim=1) - if(lprint) write(6,*) "Finding matches of the bc planes." - elseif(verify("abc",str(i)).eq.2) then - SAV%axes(i)=2 - SAV%abc=cshift(SAV%abc,shift=2) - SAV%lat1(:,:)=cshift(SAV%lat1(:,:),shift=2,dim=1) - SAV%lat2(:,:)=cshift(SAV%lat2(:,:),shift=2,dim=1) - if(lprint) write(6,*) "Finding matches of the ca planes." - end if - end do - - - return - end subroutine pick_axis -!!!############################################################################# - !!!############################################################################# !!! cycles lattice 1 @@ -180,28 +50,26 @@ end subroutine pick_axis !!! - allows for negative values on the upper off-diagonal elements !!! - stops transformation matrix from checking over previous superlattices !!! - equivalent transformation matrix will have a determinant of zero - subroutine cyc_lat1(SAV,tol,ltmp) + subroutine cyc_lat1(SAV, tol, match_method, verbose) implicit none + type(latmatch_type), intent(inout) :: SAV + integer, intent(in) :: match_method + integer, intent(in) :: verbose integer :: i,j,k integer :: n_num,count1 logical :: l1change - logical :: lprint type(tol_type) :: tol - type(latmatch_type) :: SAV integer, dimension(3,3) :: tf1,tf2 integer, dimension(2,3) :: n - double precision, dimension(3,3) :: tlat1,tlat2 - double precision, allocatable, dimension(:,:,:) :: match_tfs - logical, optional :: ltmp + real(real32), dimension(3,3) :: tlat1,tlat2 + real(real32), allocatable, dimension(:,:,:) :: match_tfs !!!----------------------------------------------------------------------------- !!! Initialised varaibles and allocates arrays !!!----------------------------------------------------------------------------- - lprint=.false. - if(present(ltmp)) lprint=ltmp allocate(match_tfs(tol%maxfit,3,3)) - match_tfs=0.D0 + match_tfs=0._real32 SAV%nfit=0 count1=0 n=0 @@ -271,11 +139,11 @@ subroutine cyc_lat1(SAV,tol,ltmp) !!! Creates transformation matrix using n array !!!----------------------------------------------------------------------------- tf1=convert_n_tf1(n,SAV%axes(1)) -! if(abs(nint(get_area(dble(tf1(1,:)),dble(tf1(2,:))))).gt.tol%area)then +! if(abs(nint(get_area(real(tf1(1,:),real32),real(tf1(2,:),real32)))).gt.tol%area)then ! n(1,1)=n(1,1)-1 ! l1change=.true. ! cycle - if(abs(get_area(dble(tf1(1,:)),dble(tf1(2,:)))).lt.0.99D0) goto 103 + if(abs(get_area(real(tf1(1,:),real32),real(tf1(2,:),real32))).lt.0.99_real32) goto 103 ! tf1(1,:)=(/1,0,0/) @@ -298,7 +166,7 @@ subroutine cyc_lat1(SAV,tol,ltmp) !!! Generates corresponding superlattice of 2nd lattice that will best ... !!! ... fit with current superlattice of 1st lattice. !!!----------------------------------------------------------------------------- - tlat2=cyc_lat2(SAV,tol,tlat1,tf1,tf2,match_tfs) + tlat2=cyc_lat2(SAV,tol,tlat1,tf1,tf2,match_tfs, match_method) count1=count1+1 @@ -315,14 +183,14 @@ subroutine cyc_lat1(SAV,tol,ltmp) do i=1,SAV%nfit if(all(abs(& match_tfs(SAV%nfit+1,:2,:3)-& - match_tfs(i,:2,:3)).lt.1.D-5)) goto 103 + match_tfs(i,:2,:3)).lt.1.E-5_real32)) goto 103 end do !!!----------------------------------------------------------------------------- !!! Checks whether corresponding superlattices are within tolerance factors !!!----------------------------------------------------------------------------- - if(tol_check(SAV,tol,tlat1,tlat2,tf1,tf2,lprint))then + if(tol_check(SAV,tol,tlat1,tlat2,tf1,tf2,verbose))then !!-------------------------------------------------------------------- !! Handles counters accordingly !!-------------------------------------------------------------------- @@ -339,13 +207,13 @@ subroutine cyc_lat1(SAV,tol,ltmp) !!! Checks whether any stop conditions are met !!!----------------------------------------------------------------------------- if(SAV%nfit.eq.tol%maxfit) then - if(lprint) & - write(6,'(/,"Number of fits reached maxfits ",I0)') SAV%nfit + if(verbose.gt.0) & + write(*,'(/,"Number of fits reached maxfits ",I0)') SAV%nfit return end if if(lstop.and.count1.gt.100) then - if(lprint) & - write(6,'(/,"Stopped as we reached ",I0," failed checks.")')& + if(verbose.gt.0) & + write(*,'(/,"Stopped as we reached ",I0," failed checks.")')& count1 return end if @@ -368,15 +236,16 @@ end subroutine cyc_lat1 !!!############################################################################# !!! cycles lattice 2 !!!############################################################################# - function cyc_lat2(SAV,tol,tlat1,tf1,tf2,match_tfs) result(tlat2) + function cyc_lat2(SAV,tol,tlat1,tf1,tf2,match_tfs, match_method) result(tlat2) implicit none integer :: i,j type(tol_type) :: tol type(latmatch_type) :: SAV integer, dimension(3,3) :: tf1,tf2 integer, dimension(3,3) :: it1_mat,it2_mat - double precision, dimension(3,3) :: t_mat,tlat1,tlat2 - double precision, dimension(:,:,:) :: match_tfs + real(real32), dimension(3,3) :: t_mat,tlat1,tlat2 + real(real32), dimension(:,:,:) :: match_tfs + integer, intent(in) :: match_method select case(match_method) @@ -394,8 +263,8 @@ function cyc_lat2(SAV,tol,tlat1,tf1,tf2,match_tfs) result(tlat2) !!! This can be used to make the simplest conversion from an identity ... !!! ... transformation of lat1 and the corresponding transformation of lat2. !!!----------------------------------------------------------------------------- - SAV%lreduced=.false. - match_tfs(SAV%nfit+1,:,:)=find_tf((dble(tf1)),(dble(tf2))) + SAV%reduced=.false. + match_tfs(SAV%nfit+1,:,:)=find_tf((real(tf1,real32)),(real(tf2,real32))) if(any(isnan(match_tfs(SAV%nfit+1,:,:)))) goto 201 t_mat(:,:)=match_tfs(SAV%nfit+1,:,:) if(ierr_compare.ge.1) then @@ -408,7 +277,7 @@ function cyc_lat2(SAV,tol,tlat1,tf1,tf2,match_tfs) result(tlat2) end if - reduce_if: if(lreduce)then + reduce_if: if(SAV%reduce)then !t_mat=transpose(t_mat) !NOT SURE WHY TRANSPOSED it1_mat(:,:)=0 it2_mat(:,:)=0 @@ -416,10 +285,10 @@ function cyc_lat2(SAV,tol,tlat1,tf1,tf2,match_tfs) result(tlat2) it2_mat(3,:)=nint(t_mat(3,:)) do i=1,2 t_mat(i,:)=reduce_vec_gcd(t_mat(i,:)) - if(any(abs(t_mat(i,:)-nint(t_mat(i,:))).gt.1.D-5)) exit reduce_if + if(any(abs(t_mat(i,:)-nint(t_mat(i,:))).gt.1.E-5_real32)) exit reduce_if it2_mat(i,:)=nint(t_mat(i,:)) do j=1,3 - if(match_tfs(SAV%nfit+1,j,i).ne.0.D0)then + if(match_tfs(SAV%nfit+1,j,i).ne.0._real32)then it1_mat(i,i)=nint(t_mat(i,j)/match_tfs(SAV%nfit+1,j,i)) exit end if @@ -427,10 +296,10 @@ function cyc_lat2(SAV,tol,tlat1,tf1,tf2,match_tfs) result(tlat2) if(all(it2_mat(i,:).eq.0)) exit reduce_if if(it1_mat(i,i).eq.0) exit reduce_if end do - if(abs(get_area(dble(tf1(1,:)),dble(tf1(2,:)))).lt.& - abs(get_area(dble(it1_mat(1,:)),dble(it1_mat(2,:)))))& + if(abs(get_area(real(tf1(1,:),real32),real(tf1(2,:),real32))).lt.& + abs(get_area(real(it1_mat(1,:),real32),real(it1_mat(2,:),real32))))& exit reduce_if - SAV%lreduced=.true. + SAV%reduced=.true. tf1=it1_mat tf2=it2_mat !tf2=matmul(tf2,it2_mat) !WHY WAS THIS USED? @@ -455,10 +324,10 @@ end function cyc_lat2 function get_lat2(SAV,tlat1) result(tf) implicit none integer :: i,kmax - double precision :: dtmp,t_area,ang1,ang2,t_ang + real(real32) :: dtmp,t_area,ang1,ang2,t_ang type(latmatch_type) :: SAV integer, dimension(3,3) :: tf,it_mat - double precision, dimension(3,3) :: t_mat,t_lat,tlat1,tlat2 + real(real32), dimension(3,3) :: t_mat,t_lat,tlat1,tlat2 tf=0 @@ -473,8 +342,8 @@ function get_lat2(SAV,tlat1) result(tf) !!!----------------------------------------------------------------------------- ang1=acos(dot_product(tlat1(1,:),tlat1(2,:))/& (modu(tlat1(1,:)*modu(tlat1(2,:))))) - t_area=1000.D0 - t_ang=5.D0 + t_area=1000._real32 + t_ang=5._real32 kmax=1 if(SAV%axes(2).eq.3) kmax=3 t_lat=SAV%lat2 @@ -498,14 +367,14 @@ function get_lat2(SAV,tlat1) result(tf) t_mat=find_tf(t_lat,tlat1) it_mat=nint(t_mat) - tlat2=matmul(dble(it_mat),t_lat) + tlat2=matmul(real(it_mat,real32),t_lat) ang2=acos(dot_product(tlat2(1,:),tlat2(2,:))/& (modu(tlat2(1,:))*modu(tlat2(2,:)))) t_mat=tlat1-tlat2 dtmp=get_area(t_mat(1,:),t_mat(2,:)) - t_area=1000.D0 + t_area=1000._real32 !! SORT OUT HANDLING OF AREA COMPARISON - if(dtmp.le.t_area.and.&!-1.D-8.and.& + if(dtmp.le.t_area.and.&!-1.E-8_real32.and.& abs(ang1-ang2).lt.t_ang)then if(i.ne.1) it_mat(:,:)=cshift(it_mat(:,:),shift=1-i,dim=2) tf=it_mat @@ -530,8 +399,8 @@ function get_lat2_alt(SAV,tol,tlat1) result(tf) type(latmatch_type) :: SAV integer, dimension(2,3) :: m integer, dimension(3,3) :: tf - double precision, dimension(3,3) :: tlat1 - double precision, dimension(3,3) :: mA,mB,S,newlat + real(real32), dimension(3,3) :: tlat1 + real(real32), dimension(3,3) :: mA,mB,S,newlat logical :: lchange @@ -540,6 +409,7 @@ function get_lat2_alt(SAV,tol,tlat1) result(tf) !!! IF tf RETURNED AS ALL 0, THEN NO MATCH FOUND + lchange = .false. m_num=0 m_max=ceiling(& get_area(tlat1(1,:),tlat1(2,:))/get_area(SAV%lat2(1,:),SAV%lat2(2,:))) @@ -549,10 +419,10 @@ function get_lat2_alt(SAV,tol,tlat1) result(tf) mB(i,j)=dot_product(SAV%lat2(i,:),SAV%lat2(j,:)) end do end do - S=1.D0 - S(:,:)=sqrt(mA(1,1))*sqrt(mA(2,2))*cos(pi/2.D0-tol%ang) + S=1._real32 + S(:,:)=sqrt(mA(1,1))*sqrt(mA(2,2))*cos(pi/2._real32-tol%ang) do i=1,3 - S(i,i)=(2.D0*tol%vec)*mA(i,i) + S(i,i)=(2._real32*tol%vec)*mA(i,i) end do @@ -575,7 +445,7 @@ function get_lat2_alt(SAV,tol,tlat1) result(tf) !!!----------------------------------------------------------------------------- !!! Loops over the n array to check whether values are allowed !!!----------------------------------------------------------------------------- -302 mloop: do + mloop: do chngloop2: do i=2,1,-1 do j=1,SAV%axes(2) if(m(i,j).lt.0)then @@ -627,7 +497,7 @@ function get_lat2_alt(SAV,tol,tlat1) result(tf) !!!using 1 Å as the tolerance !!! probably want smaller off, diagonal differences - if(all((abs(newlat(:2,:2)-mA(:2,:2))-S(:2,:2)).lt.0.D0))then + if(all((abs(newlat(:2,:2)-mA(:2,:2))-S(:2,:2)).lt.0._real32))then if(ierr_compare.gt.1)then write(0,*) "success" write(0,'(3(I0,1X))') tf @@ -651,18 +521,19 @@ end function get_lat2_alt !!!############################################################################# !!! Checks whether the supplied superlattices fit within the tolerances !!!############################################################################# - function tol_check(SAV,tol,tlat1,tlat2,tf1,tf2,lprint) result(lmatch) + function tol_check(SAV,tol,tlat1,tlat2,tf1,tf2,verbose) result(lmatch) implicit none + type(latmatch_type), intent(inout) :: SAV + real(real32), dimension(3,3), intent(in) :: tlat1, tlat2 + integer, dimension(3,3), intent(inout) :: tf1, tf2 + integer, intent(in) :: verbose + integer :: i,j - double precision :: ang1,ang2,t_area1,t_area2,diff + real(real32) :: ang1,ang2,t_area1,t_area2,diff logical :: la1a2,la1b2,l12,lmatch type(tol_type) :: tol - type(latmatch_type) :: SAV - integer, dimension(3,3) :: tf1,tf2 - double precision, dimension(2) :: mag_mat1,mag_mat2 - double precision, dimension(3) :: tvec - double precision, dimension(3,3) :: tlat1,tlat2 - logical, optional :: lprint + real(real32), dimension(2) :: mag_mat1,mag_mat2 + real(real32), dimension(3) :: tvec lmatch=.false. @@ -689,8 +560,8 @@ function tol_check(SAV,tol,tlat1,tlat2,tf1,tf2,lprint) result(lmatch) !!----------------------------------------------------------------------- !! Changed angles to all less than pi/2 to deal with negative vectors !!----------------------------------------------------------------------- - if(ang1.gt.pi/2.D0) ang1=pi-ang1 - if(ang2.gt.pi/2.D0) ang2=pi-ang2 + if(ang1.gt.pi/2._real32) ang1=pi-ang1 + if(ang2.gt.pi/2._real32) ang2=pi-ang2 if(ierr_compare.gt.1) write(0,*) ang1,ang2 !!----------------------------------------------------------------------- la1a2=(abs((mag_mat1(1)-mag_mat2(1))/mag_mat1(1)).lt.tol%vec.and.& @@ -720,56 +591,54 @@ function tol_check(SAV,tol,tlat1,tlat2,tf1,tf2,lprint) result(lmatch) !! Generating unit vector c axis for both superlattices ... !! ... perpendicular to the interface plane. !!----------------------------------------------------------------------- - tf1(3,:)=nint(uvec(cross(dble(tf1(1,:)),dble(tf1(2,:))))) - tf2(3,:)=nint(uvec(cross(dble(tf2(1,:)),dble(tf2(2,:))))) + tf1(3,:)=nint(uvec(cross(real(tf1(1,:),real32),real(tf1(2,:),real32)))) + tf2(3,:)=nint(uvec(cross(real(tf2(1,:),real32),real(tf2(2,:),real32)))) !!----------------------------------------------------------------------- !! Prints the mismatches for the current successful match !!----------------------------------------------------------------------- - if(present(lprint))then - if(lprint)then - write(6,'(/,A,I0,2X,A,I0)') & - "Fit number: ",SAV%nfit+1,& - "Area increase: ",& - nint(get_area(dble(tf1(1,:)),dble(tf1(2,:)))) - write(6,'(" Transmat 1: Transmat 2:")') - write(6,'((/,1X,3(3X,A1),3X,3(3X,A1)))') SAV%abc,SAV%abc - write(6,'(3(/,2X,3(I3," "),3X,3(I3," ")))') & - tf1(1,1:3),tf2(1,1:3),& - tf1(2,1:3),tf2(2,1:3),& - tf1(3,1:3),tf2(3,1:3) - write(6,'(" vector mismatch (%) = ",F0.9)') diff*100.D0 - write(6,'(" angle mismatch (°) = ",F0.9)') abs(ang1-ang2)*180/pi - write(6,'(" area mismatch (%) = ",F0.9)') (& - 1-abs(t_area1/t_area2))*100.D0 - write(6,*) "reduced:",SAV%lreduced - end if + if(verbose.gt.0)then + write(*,'(/,A,I0,2X,A,I0)') & + "Fit number: ",SAV%nfit+1,& + "Area increase: ",& + nint(get_area(real(tf1(1,:),real32),real(tf1(2,:),real32))) + write(*,'(" Transmat 1: Transmat 2:")') + write(*,'((/,1X,3(3X,A1),3X,3(3X,A1)))') SAV%abc,SAV%abc + write(*,'(3(/,2X,3(I3," "),3X,3(I3," ")))') & + tf1(1,1:3),tf2(1,1:3),& + tf1(2,1:3),tf2(2,1:3),& + tf1(3,1:3),tf2(3,1:3) + write(*,'(" vector mismatch (%) = ",F0.9)') diff*100._real32 + write(*,'(" angle mismatch (°) = ",F0.9)') abs(ang1-ang2)*180/pi + write(*,'(" area mismatch (%) = ",F0.9)') (& + 1-abs(t_area1/t_area2))*100._real32 + write(*,*) "reduced:",SAV%reduced end if !!----------------------------------------------------------------------- !! Checks if best mismatch and saves accordingly !!----------------------------------------------------------------------- - best_check: do i=1,tol%nstore + best_check: do i=1,SAV%max_num_matches if(i.gt.SAV%nfit)then - SAV%tol(i,1)=diff*100.D0 + SAV%tol(i,1)=diff*100._real32 SAV%tol(i,2)=abs(ang1-ang2) - SAV%tol(i,3)=(1-abs(t_area1/t_area2))*100.D0 + SAV%tol(i,3)=(1-abs(t_area1/t_area2))*100._real32 SAV%tf1(i,:,:)=tf1(:,:) SAV%tf2(i,:,:)=tf2(:,:) exit best_check end if - if(diff*100.D0.le.SAV%tol(i,1).and.& + if(diff*100._real32.le.SAV%tol(i,1).and.& abs(ang1-ang2).le.SAV%tol(i,2).and.& - (1-abs(t_area1/t_area2))*100.D0.le.SAV%tol(i,3)) then - if(nint(get_area(dble(tf1(1,:)),dble(tf1(2,:)))).ge.& - nint(get_area(dble(SAV%tf1(i,1,:)),dble(SAV%tf1(i,2,:)))))& + (1-abs(t_area1/t_area2))*100._real32.le.SAV%tol(i,3)) then + if(nint(get_area(real(tf1(1,:),real32),real(tf1(2,:),real32))).ge.& + nint(get_area(real(SAV%tf1(i,1,:),real32),real(SAV%tf1(i,2,:),real32))))& cycle best_check - do j=tol%nstore,i+1,-1 + do j=SAV%max_num_matches,i+1,-1 SAV%tol(j,:)=SAV%tol(j-1,:) SAV%tf1(j,:,:)=SAV%tf1(j-1,:,:) SAV%tf2(j,:,:)=SAV%tf2(j-1,:,:) end do - SAV%tol(i,1)=diff*100.D0 + SAV%tol(i,1)=diff*100._real32 SAV%tol(i,2)=abs(ang1-ang2) - SAV%tol(i,3)=(1-abs(t_area1/t_area2))*100.D0 + SAV%tol(i,3)=(1-abs(t_area1/t_area2))*100._real32 SAV%tf1(i,:,:)=tf1(:,:) SAV%tf2(i,:,:)=tf2(:,:) exit best_check @@ -790,16 +659,16 @@ end function tol_check function lat_check(SAV,tol,lat) result(lcheck) implicit none integer :: i - double precision :: ang1,ang2,tiny + real(real32) :: ang1,ang2,tiny logical :: lcheck,lmatch_aa,lmatch_ab type(tol_type) :: tol type(latmatch_type) :: SAV - double precision, dimension(3,3) :: lat,tlat + real(real32), dimension(3,3) :: lat,tlat - tiny=1.D-6 + tiny=1.E-6_real32 lcheck=.false. - lat_loop: do i=1,min(tol%nstore,SAV%nfit) + lat_loop: do i=1,min(SAV%max_num_matches,SAV%nfit) tlat=matmul(SAV%tf1(i,:,:),SAV%lat1) ang1=acos(dot_product(lat(1,:),lat(2,:))/(& sqrt(dot_product(lat(1,:),lat(1,:)))*& @@ -807,8 +676,8 @@ function lat_check(SAV,tol,lat) result(lcheck) ang2=acos(dot_product(tlat(1,:),tlat(2,:))/(& sqrt(dot_product(tlat(1,:),tlat(1,:)))*& sqrt(dot_product(tlat(2,:),tlat(2,:))))) - if(ang1.gt.pi/2.D0) ang1=pi-ang1 - if(ang2.gt.pi/2.D0) ang2=pi-ang2 + if(ang1.gt.pi/2._real32) ang1=pi-ang1 + if(ang2.gt.pi/2._real32) ang2=pi-ang2 if(abs(ang1-ang2).lt.tiny)then lmatch_aa=& (abs(dot_product(lat(1,:),lat(1,:))-& @@ -871,27 +740,27 @@ subroutine endcode(SAV) type(latmatch_type) :: SAV - write(6,*) + write(*,*) if(SAV%nfit.eq.0)then - write(6,'(" No matches were found within the tolerances supplied.")') - write(6,*) + write(*,'(" No matches were found within the tolerances supplied.")') + write(*,*) call exit(1) end if - write(6,'(1X,"BEST MATCH Area increase: ",I0)') & - nint(get_area(real(SAV%tf1(1,1,:),real12),real(SAV%tf1(1,2,:),real12))) - write(6,'(" Transmat 1: Transmat 2:")') - write(6,'((/,1X,3(3X,A1),3X,3(3X,A1)),3(/,2X,3(I3," "),3X,3(I3," ")))') & + write(*,'(1X,"BEST MATCH Area increase: ",I0)') & + nint(get_area(real(SAV%tf1(1,1,:),real32),real(SAV%tf1(1,2,:),real32))) + write(*,'(" Transmat 1: Transmat 2:")') + write(*,'((/,1X,3(3X,A1),3X,3(3X,A1)),3(/,2X,3(I3," "),3X,3(I3," ")))') & SAV%abc,SAV%abc,& SAV%tf1(1,1,1:3),SAV%tf2(1,1,1:3),& SAV%tf1(1,2,1:3),SAV%tf2(1,2,1:3),& SAV%tf1(1,3,1:3),SAV%tf2(1,3,1:3) - write(6,'(" vector mismatch (%) = ",F0.9)') SAV%tol(1,1) - write(6,'(" angle mismatch (°) = ",F0.9)') SAV%tol(1,2)*180/pi - write(6,'(" area mismatch (%) = ",F0.9)') SAV%tol(1,3) - write(6,*) + write(*,'(" vector mismatch (%) = ",F0.9)') SAV%tol(1,1) + write(*,'(" angle mismatch (°) = ",F0.9)') SAV%tol(1,2)*180/pi + write(*,'(" area mismatch (%) = ",F0.9)') SAV%tol(1,3) + write(*,*) - write(6,'(A)') "EXITING" + write(*,'(A)') "EXITING" return @@ -904,15 +773,15 @@ end subroutine endcode !!!############################################################################# function vec_comp(S1,S1p,S2p,delta) result(match) implicit none - double precision :: ct,cp,cv,th,ph,va - double precision :: beta,pm1,alpha,pm2 - double precision :: mS1,mS1p,mS2p,tiny,md - double precision, dimension(2) :: match - double precision, dimension(3) :: S1,S1p,S2p,delta + real(real32) :: ct,cp,cv,th,ph,va + real(real32) :: beta,pm1,alpha,pm2 + real(real32) :: mS1,mS1p,mS2p,tiny,md + real(real32), dimension(2) :: match + real(real32), dimension(3) :: S1,S1p,S2p,delta - match=0.D0 - tiny=1.D-8 + match=0._real32 + tiny=1.E-8_real32 mS1=modu(S1) mS1p=modu(S1p) mS2p=modu(S2p) @@ -926,9 +795,9 @@ function vec_comp(S1,S1p,S2p,delta) result(match) va=acos(dot_product(S1,S2p) /(mS1* mS2p)) beta=mS1*(cv-ct*cp)/(mS2p*sin(acos(ct))**2.0) - pm1=(cv-ct*cp)**2.0 - (sin(th)*sin(ph))**2.0 !- md*(sin(th)/mS1)**2.D0 - if(abs(pm1).lt.tiny.or.pm1+(md*sin(th)/mS1)**2.D0.gt.0.D0) pm1=0.D0 - pm1=mS1*sqrt(pm1)/( mS2p*(1-ct**2.D0) ) + pm1=(cv-ct*cp)**2.0 - (sin(th)*sin(ph))**2.0 !- md*(sin(th)/mS1)**2._real32 + if(abs(pm1).lt.tiny.or.pm1+(md*sin(th)/mS1)**2._real32.gt.0._real32) pm1=0._real32 + pm1=mS1*sqrt(pm1)/( mS2p*(1-ct**2._real32) ) if(abs(beta+pm1-nint(beta+pm1)).lt.& abs(beta-pm1-nint(beta-pm1)))then match(1)=beta+pm1 @@ -937,12 +806,12 @@ function vec_comp(S1,S1p,S2p,delta) result(match) end if beta=match(1) - !t_beta=beta+pm1*(-1.0)**dble(i) + !t_beta=beta+pm1*(-1.0)**real(i,real32) alpha=-( beta*mS2p*ct - mS1*cp )/mS1p - pm2=-(beta*mS2p*sin(th))**2.D0 & - -(mS1*sin(ph))**2.D0 + & - 2.D0*beta*mS1*mS2p*(cv - ct*cp) !- md - if(abs(pm2).lt.tiny.or.pm2+md**2.D0.gt.0.D0) pm2=0.D0 + pm2=-(beta*mS2p*sin(th))**2._real32 & + -(mS1*sin(ph))**2._real32 + & + 2._real32*beta*mS1*mS2p*(cv - ct*cp) !- md + if(abs(pm2).lt.tiny.or.pm2+md**2._real32.gt.0._real32) pm2=0._real32 pm2=sqrt(pm2)/mS1p @@ -962,71 +831,76 @@ end function vec_comp !!! Isiah lattice match !!! Program to match lattices of two position cards. !!!############################################################################# - subroutine lattice_matching(SAV,tol,bas1,bas2,plane1,plane2,nmiller,lprint) - use mod_sym + subroutine lattice_matching( & + SAV, tol, structure_lw, structure_up, & + miller_lw, miller_up, max_num_planes, & + verbose, tol_sym & + ) + use artemis__sym use plane_matching implicit none + + type(latmatch_type), intent(inout) :: SAV + type(basis_type), intent(in) :: structure_lw,structure_up + integer, dimension(3), intent(in) :: miller_lw,miller_up + integer, intent(in) :: max_num_planes + integer, intent(in) :: verbose + real(real32), intent(in) :: tol_sym type(sym_type) :: grp1,grp2 type(tol_type) :: tol - type(pm_tol_type) :: pm_tol - type(latmatch_type) :: SAV - double precision, dimension(3,3) :: tf - double precision, dimension(3,3) :: lat1,lat2 !original lattices. - double precision, dimension(3,3) :: templat1,templat2 !tmp lattices to feed into plane matching. + type(tol_type) :: pm_tol + real(real32), dimension(3,3) :: tf + real(real32), dimension(3,3) :: lat1,lat2 !original lattices. + real(real32), dimension(3,3) :: templat1,templat2 !tmp lattices to feed into plane matching. integer :: itmp1,nsym1,nsym2 integer :: m1,m2,m3,i1,i2,i3,loc integer :: loopsize !size of the main loops integer :: i,j,num_of_transforms ! n = number of output transforms - double precision :: dtmp1 + real(real32) :: dtmp1 logical, allocatable, dimension(:) :: lvec1 integer, dimension(3,3) :: tmat1,tmat2 integer, dimension(3,3) :: transform1,transform2 !The transformations output by planecutter. - real, dimension(3) :: rvec1, rvec2 - real, dimension(3,3) :: rmat1 + real(real32), dimension(3) :: rvec1, rvec2 + real(real32), dimension(3,3) :: rmat1 - double precision, allocatable, dimension(:,:,:) :: tmpsym1,tmpsym2,tmpsym - double precision, allocatable, dimension(:,:,:) :: transform1_saved,transform2_saved !The transformations output by plane cutter + real(real32), allocatable, dimension(:,:,:) :: tmpsym1,tmpsym2,tmpsym + real(real32), allocatable, dimension(:,:,:) :: transform1_saved,transform2_saved !The transformations output by plane cutter integer, allocatable, dimension(:,:,:) :: Tcellmatch_1,Tcellmatch_2 !The transformation matrices output from the cell_match program for lattices 1 and 2. - double precision, allocatable, dimension(:,:,:) :: Tsaved_1,Tsaved_2 - double precision, allocatable, dimension(:,:,:) :: big_T_1,big_T_2 ! 3x3 versions of the matrices output by cell_match - double precision, dimension(3,3) :: dummy_mat1,dummy_mat2 ! temporary matrices used when the info is stored in a tensor. - double precision, dimension(2,2) :: temp_mat1,temp_mat2 ! temporary matrices used when the info is stored in a tensor. - double precision, allocatable, dimension(:,:,:) :: comb_trans_1,comb_trans_2 !The combined transformations (planecutter output)x(cellmatch output). + real(real32), allocatable, dimension(:,:,:) :: Tsaved_1,Tsaved_2 + real(real32), allocatable, dimension(:,:,:) :: big_T_1,big_T_2 ! 3x3 versions of the matrices output by cell_match + real(real32), dimension(3,3) :: dummy_mat1,dummy_mat2 ! temporary matrices used when the info is stored in a tensor. + real(real32), dimension(2,2) :: temp_mat1,temp_mat2 ! temporary matrices used when the info is stored in a tensor. + real(real32), allocatable, dimension(:,:,:) :: comb_trans_1,comb_trans_2 !The combined transformations (planecutter output)x(cellmatch output). - double precision, allocatable, dimension(:,:) :: tolerances,saved_tolerances + real(real32), allocatable, dimension(:,:) :: tolerances,saved_tolerances integer, allocatable, dimension(:,:) :: ivtmp1,miller1,miller2 integer, dimension(3) :: ivtmp2 - type(bas_type), intent(in) :: bas1,bas2 - integer, intent(in) :: nmiller - logical, optional, intent(in) :: lprint - integer, dimension(3), optional, intent(in) :: plane1,plane2 !!-------------------------------------------------------------------------- !! sets initial variables !!-------------------------------------------------------------------------- SAV%nfit = 0 - allocate(transform1_saved(tol%nstore,3,3)) - allocate(transform2_saved(tol%nstore,3,3)) - allocate(Tsaved_1(tol%nstore,2,2)) - allocate(Tsaved_2(tol%nstore,2,2)) - transform1_saved = 0.D0 - transform2_saved = 0.D0 - Tsaved_1 = 0.D0 - Tsaved_2 = 0.D0 - allocate(tolerances(tol%nstore,3)) - allocate(saved_tolerances(tol%nstore,3)) + allocate(transform1_saved(SAV%max_num_matches,3,3)) + allocate(transform2_saved(SAV%max_num_matches,3,3)) + allocate(Tsaved_1(SAV%max_num_matches,2,2)) + allocate(Tsaved_2(SAV%max_num_matches,2,2)) + transform1_saved = 0._real32 + transform2_saved = 0._real32 + Tsaved_1 = 0._real32 + Tsaved_2 = 0._real32 + allocate(tolerances(SAV%max_num_matches,3)) + allocate(saved_tolerances(SAV%max_num_matches,3)) saved_tolerances = INF lat1 = SAV%lat1 lat2 = SAV%lat2 pm_tol%maxsize=tol%maxsize pm_tol%maxfit=tol%maxfit - pm_tol%nstore=tol%nstore pm_tol%vec=tol%vec pm_tol%ang=tol%ang pm_tol%area=tol%area @@ -1039,16 +913,14 @@ subroutine lattice_matching(SAV,tol,bas1,bas2,plane1,plane2,nmiller,lprint) !!-------------------------------------------------------------------------- !! finds and stores symmetry operations for each lattice !!-------------------------------------------------------------------------- - s_end=0 - call sym_setup(grp1,lat1)!,predefined=.true.,new_start=.true.) - call check_sym(grp1,bas1,lsave=.true.) - allocate(tmpsym1(grp1%nsym,3,3)) + call grp1%init(lat1, tol_sym=tol_sym,new_start=.true.) + call check_sym(grp1,structure_lw,lsave=.true.,tol_sym=tol_sym) + allocate(tmpsym1(3,3,grp1%nsym)) - s_end=0 - call sym_setup(grp2,lat2)!,predefined=.true.,new_start=.true.) - call check_sym(grp2,bas2,lsave=.true.) - allocate(tmpsym2(grp2%nsym,3,3)) + call grp2%init(lat2, tol_sym=tol_sym,new_start=.true.) + call check_sym(grp2,structure_up,lsave=.true.,tol_sym=tol_sym) + allocate(tmpsym2(3,3,grp2%nsym)) !!-------------------------------------------------------------------------- @@ -1056,7 +928,7 @@ subroutine lattice_matching(SAV,tol,bas1,bas2,plane1,plane2,nmiller,lprint) !!-------------------------------------------------------------------------- loopsize=10 allocate(ivtmp1((2*loopsize+1)**3,3)) - !allocate(ivtmp1(nmiller,3)) + !allocate(ivtmp1(max_num_planes,3)) !!-------------------------------------------------------------------------- @@ -1064,9 +936,9 @@ subroutine lattice_matching(SAV,tol,bas1,bas2,plane1,plane2,nmiller,lprint) !!-------------------------------------------------------------------------- ivtmp1=0 itmp1=0 - if(present(plane1))then - allocate(miller1(1,size(plane1))) - miller1(1,:3)=plane1(:3) + if(any(miller_lw.ne.0))then + allocate(miller1(1,size(miller_lw))) + miller1(1,:3)=miller_lw(:3) else mloop1: do i1=1,loopsize m1=floor((i1)/2.0)*(-1)**i1 @@ -1074,37 +946,37 @@ subroutine lattice_matching(SAV,tol,bas1,bas2,plane1,plane2,nmiller,lprint) m2=floor((i2)/2.0)*(-1)**i2 mloop3: do i3=1,loopsize m3=floor((i3)/2.0)*(-1)**i3 - if ( .not.is_unique( (/m1,m2,m3/), grp1%sym(:,:3,:3) ) ) & + if ( .not.is_unique( [ m1, m2, m3 ], grp1%sym(:3,:3,:) ) ) & cycle mloop3 - itmp1=itmp1+1 - ivtmp1(itmp1,:)=(/m1,m2,m3/) - !if(itmp1.eq.nmiller) exit mloop1 + itmp1 = itmp1 + 1 + ivtmp1(itmp1,:) = [ m1, m2, m3 ] + !if(itmp1.eq.max_num_planes) exit mloop1 end do mloop3 end do mloop2 end do mloop1 do i=1,itmp1 - loc=minloc(& - abs(ivtmp1(i:itmp1,1))+& - abs(ivtmp1(i:itmp1,2))+& - abs(ivtmp1(i:itmp1,3)),dim=1)+i-1 - ivtmp2(:)=ivtmp1(i,:) - ivtmp1(i,:)=ivtmp1(loc,:) - ivtmp1(loc,:)=ivtmp2(:) + loc = minloc(& + abs(ivtmp1(i:itmp1,1)) + & + abs(ivtmp1(i:itmp1,2)) + & + abs(ivtmp1(i:itmp1,3)),dim=1) + i - 1 + ivtmp2(:) = ivtmp1(i,:) + ivtmp1(i,:) = ivtmp1(loc,:) + ivtmp1(loc,:) = ivtmp2(:) end do - itmp1=min(itmp1,nmiller) + itmp1 = min(itmp1,max_num_planes) allocate(miller1(itmp1,3)) - miller1(:,:)=ivtmp1(:itmp1,:) + miller1(:,:) = ivtmp1(:itmp1,:) end if !!-------------------------------------------------------------------------- !! generate all unique planes for lattice 2 !!-------------------------------------------------------------------------- - itmp1=0 - ivtmp1=0 - if(present(plane2))then - allocate(miller2(1,size(plane2))) - miller2(1,:3)=plane2(:3) + itmp1 = 0 + ivtmp1 = 0 + if(any(miller_up.ne.0))then + allocate(miller2(1,size(miller_up))) + miller2(1,:3)=miller_up(:3) else mloop4: do i1=1,loopsize m1=floor((i1)/2.0)*(-1)**i1 @@ -1112,128 +984,126 @@ subroutine lattice_matching(SAV,tol,bas1,bas2,plane1,plane2,nmiller,lprint) m2=floor((i2)/2.0)*(-1)**i2 mloop6: do i3=1,loopsize m3=floor((i3)/2.0)*(-1)**i3 - if ( .not.is_unique( (/m1,m2,m3/), grp2%sym(:,:3,:3) ) ) & + if ( .not.is_unique( (/m1,m2,m3/), grp2%sym(:3,:3,:) ) ) & cycle mloop6 itmp1=itmp1+1 ivtmp1(itmp1,:)=(/m1,m2,m3/) - !if(itmp1.eq.nmiller) exit mloop4 + !if(itmp1.eq.max_num_planes) exit mloop4 end do mloop6 end do mloop5 end do mloop4 do i=1,itmp1 - loc=minloc(& - abs(ivtmp1(i:itmp1,1))+& - abs(ivtmp1(i:itmp1,2))+& - abs(ivtmp1(i:itmp1,3)),dim=1)+i-1 - ivtmp2(:)=ivtmp1(i,:) - ivtmp1(i,:)=ivtmp1(loc,:) - ivtmp1(loc,:)=ivtmp2(:) + loc = minloc(& + abs(ivtmp1(i:itmp1,1)) + & + abs(ivtmp1(i:itmp1,2)) + & + abs(ivtmp1(i:itmp1,3)),dim=1) + i - 1 + ivtmp2(:) = ivtmp1(i,:) + ivtmp1(i,:) = ivtmp1(loc,:) + ivtmp1(loc,:) = ivtmp2(:) end do - itmp1=min(itmp1,nmiller) + itmp1 = min(itmp1,max_num_planes) allocate(miller2(itmp1,3)) - miller2(:,:)=ivtmp1(:itmp1,:) + miller2(:,:) = ivtmp1(:itmp1,:) end if - if(present(lprint))then - if(lprint)then - write(6,*) - write(6,'(1X,"Miller planes considered for lower material: ",I0)') & - size(miller1(:,1)) - do i=1,size(miller1(:,1)) - write(6,'(2X,I2,")",3X,3(3X,I0))') i,miller1(i,:) - end do - write(6,*) - write(6,'(1X,"Miller planes considered for upper material: ",I0)') & - size(miller2(:,1)) - do i=1,size(miller2(:,1)) - write(6,'(2X,I2,")",3X,3(3X,I0))') i,miller2(i,:) - end do - write(6,*) - end if + if(verbose.gt.0)then + write(*,*) + write(*,'(1X,"Miller planes considered for lower material: ",I0)') & + size(miller1(:,1)) + do i=1,size(miller1(:,1)) + write(*,'(2X,I2,")",3X,3(3X,I0))') i,miller1(i,:) + end do + write(*,*) + write(*,'(1X,"Miller planes considered for upper material: ",I0)') & + size(miller2(:,1)) + do i=1,size(miller2(:,1)) + write(*,'(2X,I2,")",3X,3(3X,I0))') i,miller2(i,:) + end do + write(*,*) end if !!-------------------------------------------------------------------------- !! cycles through the unique miller planes to find matches !!-------------------------------------------------------------------------- - allocate(tmpsym(max(grp1%nsym,grp2%nsym),3,3)) - MAINLOOP1: do m1=1,size(miller1(:,1),dim=1) - transform1 = nint(planecutter(lat1,dble(miller1(m1,:)))) + allocate(tmpsym(3,3,max(grp1%nsym,grp2%nsym))) + MAINLOOP1: do m1 = 1, size( miller1, dim = 1 ) + transform1 = nint(planecutter(lat1,real(miller1(m1,:),real32))) if (all(transform1 .eq. 0)) cycle MAINLOOP1 templat1 = matmul(transform1,lat1) - tmpsym=0.D0 + tmpsym = 0._real32 do i=1,grp1%nsym - tmpsym(i,:3,:3) = & - matmul(grp1%sym(i,:3,:3),inverse_3x3(dble(transform1))) + tmpsym(:3,:3,i) = & + matmul(grp1%sym(:3,:3,i),inverse_3x3(real(transform1,real32))) ! next step required to transform properly into the space? - tmpsym(i,:3,:3) = & - matmul(dble(transform1),tmpsym(i,:3,:3)) + tmpsym(:3,:3,i) = & + matmul(real(transform1,real32),tmpsym(:3,:3,i)) end do nsym1=0 - tmpsym1=0.D0 + tmpsym1=0._real32 !!! IS THIS REASONABLE TO DO IT THIS WAY? OR DO WE NEED TO CHANGE sym TO BE IN THE NEW LAT? !!! Wait, should it be instead that the cross product of the a-b plane is always consistent? - rvec1=real(cross(templat1(1,:),templat1(2,:))) - do i=1,grp1%nsym - rmat1=real(matmul(tmpsym(i,:3,:3),templat1(:,:))) - rvec2=cross(rmat1(1,:),rmat1(2,:)) - if(all(abs( rvec1(:) - rvec2(:) ).lt.1.D-8).or.& - all(abs( rvec1(:) + rvec2(:) ).lt.1.D-8))then - nsym1=nsym1+1 - tmpsym1(nsym1,:3,:3) = tmpsym(i,:3,:3) + rvec1=cross([templat1(1,:)],[templat1(2,:)]) + do i = 1, grp1%nsym, 1 + rmat1=matmul(tmpsym(:3,:3,i),templat1(:,:)) + rvec2=cross([rmat1(1,:)],[rmat1(2,:)]) + if(all(abs( rvec1(:) - rvec2(:) ).lt.1.E-8_real32).or.& + all(abs( rvec1(:) + rvec2(:) ).lt.1.E-8_real32))then + nsym1 = nsym1 + 1 + tmpsym1(:3,:3,nsym1) = tmpsym(:3,:3,i) else cycle end if ! redundant if a-b plane works instead. !if(all(& - ! abs( templat1(3,:) - matmul(templat1(3,:),tmpsym(i,:3,:3)) )& - ! .lt.1.D-8).or.& + ! abs( templat1(3,:) - matmul(templat1(3,:),tmpsym(:3,:3,i)) )& + ! .lt.1.E-8_real32).or.& ! all(& - ! abs( templat1(3,:) + matmul(templat1(3,:),tmpsym(i,:3,:3)) )& - ! .lt.1.D-8))then + ! abs( templat1(3,:) + matmul(templat1(3,:),tmpsym(:3,:3,i)) )& + ! .lt.1.E-8_real32))then ! nsym1=nsym1+1 - ! tmpsym1(nsym1,:3,:3) = tmpsym(i,:3,:3) + ! tmpsym1(:3,:3,nsym1) = tmpsym(:3,:3,i) !end if !write(0,*) "################################" !write(0,*) i - !write(0,'(3(2X,F7.2))') tmpsym(i,:3,:3) + !write(0,'(3(2X,F7.2))') tmpsym(:3,:3,i) !write(0,*) - !write(0,'(3(2X,F7.2))') rvec1!(templat1(j,:),j=1,3)!(grp1%sym(i,j,:3),j=1,3) !tmpsym(i,:3,:3) + !write(0,'(3(2X,F7.2))') rvec1!(templat1(j,:),j=1,3)!(grp1%sym(j,:3,i),j=1,3) !tmpsym(:3,:3,i) !write(0,*) - !write(0,'(3(2X,F7.2))') rvec2!matmul(templat1(3,:),tmpsym(i,:3,:3))!(tmpsym(i,j,:3),j=1,3) + !write(0,'(3(2X,F7.2))') rvec2!matmul(templat1(3,:),tmpsym(:3,:3,i))!(tmpsym(j,:3,i),j=1,3) end do !stop MAINLOOP2: do m2=1,size(miller2(:,1),dim=1) - transform2 = nint(planecutter(lat2,dble(miller2(m2,:)))) + transform2 = nint(planecutter(lat2,real(miller2(m2,:),real32))) if (all(transform2 .eq. 0)) cycle MAINLOOP2 templat2 = matmul(transform2,lat2) - tmpsym=0.D0 - do i=1,grp2%nsym - tmpsym(i,:3,:3) = & - matmul(grp2%sym(i,:3,:3),inverse_3x3(dble(transform2))) + tmpsym=0._real32 + do i = 1, grp2%nsym, 1 + tmpsym(:3,:3,i) = & + matmul(grp2%sym(:3,:3,i),inverse_3x3(real(transform2,real32))) ! next step required to transform properly into the space? - tmpsym(i,:3,:3) = & - matmul(dble(transform2),tmpsym(i,:3,:3)) + tmpsym(:3,:3,i) = & + matmul(real(transform2,real32),tmpsym(:3,:3,i)) end do nsym2=0 - tmpsym2=0.D0 - do i=1,grp2%nsym + tmpsym2 = 0._real32 + do i = 1, grp2%nsym, 1 !write(0,*) "################################" !write(0,*) i - !write(0,'(3(2X,F7.2))') (grp2%sym(i,j,:3),j=1,3) !tmpsym(i,:3,:3) + !write(0,'(3(2X,F7.2))') (grp2%sym(j,:3,i),j=1,3) !tmpsym(:3,:3,i) !write(0,*) - !write(0,'(3(2X,F7.2))') (tmpsym(i,j,:3),j=1,3) + !write(0,'(3(2X,F7.2))') (tmpsym(j,:3,i),j=1,3) if(all(& - abs( templat2(3,:) - matmul(templat2(3,:),tmpsym(i,:3,:3)) )& - .lt.1.D-8).or.& + abs( templat2(3,:) - matmul(templat2(3,:),tmpsym(:3,:3,i)) )& + .lt.1.E-8_real32).or.& all(& - abs( templat2(3,:) + matmul(templat2(3,:),tmpsym(i,:3,:3)) )& - .lt.1.D-8))then - nsym2=nsym2+1 - tmpsym2(nsym2,:3,:3) = tmpsym(i,:3,:3) + abs( templat2(3,:) + matmul(templat2(3,:),tmpsym(:3,:3,i)) )& + .lt.1.E-8_real32))then + nsym2 = nsym2 + 1 + tmpsym2(:3,:3,nsym2) = tmpsym(:3,:3,i) end if end do @@ -1248,29 +1118,29 @@ subroutine lattice_matching(SAV,tol,bas1,bas2,plane1,plane2,nmiller,lprint) transforms2=Tcellmatch_2,& ntransforms=num_of_transforms,& matched_tols=tolerances,& - sym1=tmpsym1(:nsym1,:,:),sym2=tmpsym2(:nsym2,:,:)) + sym1=tmpsym1(:,:,:nsym1),sym2=tmpsym2(:,:,:nsym2)) !!-------------------------------------------------------------------- - !! Find the (tol%nstore) best matches overall + !! Find the (SAV%max_num_matches) best matches overall !!-------------------------------------------------------------------- loop110: do i=1,num_of_transforms IF101: if ( dot_product(tolerances(i,:),vaa_weighting).le.& - dot_product(saved_tolerances(tol%nstore,:),vaa_weighting) )then - temp_mat1(:,:) = dble(Tcellmatch_1(i,:,:)) - temp_mat2(:,:) = dble(Tcellmatch_2(i,:,:)) + dot_product(saved_tolerances(SAV%max_num_matches,:),vaa_weighting) )then + temp_mat1(:,:) = real(Tcellmatch_1(i,:,:),real32) + temp_mat2(:,:) = real(Tcellmatch_2(i,:,:),real32) IF102: if (.not.is_duplicate(& (Tsaved_1),(Tsaved_2),& (temp_mat1),(temp_mat2),& tmpsym1,tmpsym2) ) then - saved_tolerances(tol%nstore,:) = tolerances(i,:) - Tsaved_1(tol%nstore,:,:) = temp_mat1(:,:) - Tsaved_2(tol%nstore,:,:) = temp_mat2(:,:) - transform1_saved(tol%nstore,:,:) = dble(transform1(:,:)) - transform2_saved(tol%nstore,:,:) = dble(transform2(:,:)) + saved_tolerances(SAV%max_num_matches,:) = tolerances(i,:) + Tsaved_1(SAV%max_num_matches,:,:) = temp_mat1(:,:) + Tsaved_2(SAV%max_num_matches,:,:) = temp_mat2(:,:) + transform1_saved(SAV%max_num_matches,:,:) = real(transform1(:,:),real32) + transform2_saved(SAV%max_num_matches,:,:) = real(transform2(:,:),real32) - if(SAV%nfit.lt.tol%nstore) SAV%nfit = SAV%nfit + 1 + if(SAV%nfit.lt.SAV%max_num_matches) SAV%nfit = SAV%nfit + 1 call datasortmain_tols(saved_tolerances,& Tsaved_1,Tsaved_2,transform1_saved,transform2_saved) end if IF102 @@ -1285,15 +1155,15 @@ subroutine lattice_matching(SAV,tol,bas1,bas2,plane1,plane2,nmiller,lprint) !!!----------------------------------------------------------------------------- !!! Convert the 2x2 transformations to 3x3 matrices !!!----------------------------------------------------------------------------- - allocate(big_T_1(tol%nstore,3,3)) - allocate(big_T_2(tol%nstore,3,3)) + allocate(big_T_1(SAV%max_num_matches,3,3)) + allocate(big_T_2(SAV%max_num_matches,3,3)) big_T_1(:,:,:) = 0 big_T_2(:,:,:) = 0 - loop101: do i=1,tol%nstore + loop101: do i=1,SAV%max_num_matches big_T_1(i,3,3) = 1 big_T_2(i,3,3) = 1 end do loop101 - loop103: do i=1,tol%nstore + loop103: do i=1,SAV%max_num_matches big_T_1(i,:2,:2) = (Tsaved_1(i,:,:)) big_T_2(i,:2,:2) = (Tsaved_2(i,:,:)) end do loop103 @@ -1302,9 +1172,9 @@ subroutine lattice_matching(SAV,tol,bas1,bas2,plane1,plane2,nmiller,lprint) !!!----------------------------------------------------------------------------- !!! Combine 3x3 planecutter matrix with 3x3 plane matching matrix !!!----------------------------------------------------------------------------- - allocate(comb_trans_1(tol%nstore,3,3)) - allocate(comb_trans_2(tol%nstore,3,3)) - loop104: do i=1,tol%nstore + allocate(comb_trans_1(SAV%max_num_matches,3,3)) + allocate(comb_trans_2(SAV%max_num_matches,3,3)) + loop104: do i=1,SAV%max_num_matches dummy_mat1(:,:) = big_T_1(i,:,:) dummy_mat2(:,:) = transform1_saved(i,:,:) comb_trans_1(i,:,:) = matmul((dummy_mat1),(dummy_mat2)) @@ -1318,32 +1188,32 @@ subroutine lattice_matching(SAV,tol,bas1,bas2,plane1,plane2,nmiller,lprint) !!!----------------------------------------------------------------------------- !!! Reduce transformation matrices if necessary !!!----------------------------------------------------------------------------- - write(6,*) "Performing lattice match reduction" - allocate(lvec1(tol%nstore)) + write(*,*) "Performing lattice match reduction" + allocate(lvec1(SAV%max_num_matches)) lvec1=.false. - OUTLOOP: do i=1,tol%nstore + OUTLOOP: do i=1,SAV%max_num_matches SAV%tol(i,:) = saved_tolerances(i,:) - if_reduce: if(lreduce)then + if_reduce: if(reduce)then tf = find_tf(comb_trans_1(i,:,:),comb_trans_2(i,:,:)) - if(abs(abs(det(comb_trans_1(i,:,:)))-1.D0).lt.1.D-6) exit if_reduce - if(ierror.eq.1)then + if(abs(abs(det(comb_trans_1(i,:,:)))-1._real32).lt.1.E-6_real32) exit if_reduce + if(verbose.ge.1)then write(0,*) i write(0,'( 3( 3(F7.3,1X), /) )') tf end if if(any( (/ (maxval(abs(reduce_vec_gcd(tf(j,:3)))),j=1,3) /)& - .eq.0.D0))then + .eq.0._real32))then exit if_reduce else tmat1(:,:) = & reshape((/ 1, 0, 0, 0, 1, 0, 0, 0, 1 /),shape(tmat1(:,:))) tmat2(:,:) = nint(tf) do j=1,3 - dtmp1=1.D0 - if(any(abs(tf(j,:3)-nint(tf(j,:3))).gt.1.D-6))then + dtmp1=1._real32 + if(any(abs(tf(j,:3)-nint(tf(j,:3))).gt.1.E-6_real32))then dtmp1=get_vec_multiple(tf(j,:3),reduce_vec_gcd(tf(j,:3))) end if - if(abs(dtmp1-nint(dtmp1)).gt.1.D-6)then - dtmp1=get_frac_denom(1.D0/dtmp1) + if(abs(dtmp1-nint(dtmp1)).gt.1.E-6_real32)then + dtmp1=get_frac_denom(1._real32/dtmp1) end if tmat1(j,:) = tmat1(j,:3)*nint(dtmp1) tmat2(j,:) = nint(tf(j,:3)*dtmp1) @@ -1358,34 +1228,32 @@ subroutine lattice_matching(SAV,tol,bas1,bas2,plane1,plane2,nmiller,lprint) SAV%tf1(i,:,:) = nint(comb_trans_1(i,:,:)) SAV%tf2(i,:,:) = nint(comb_trans_2(i,:,:)) end do OUTLOOP - SAV%tol(:,1) = SAV%tol(:,1)*100.D0 - SAV%tol(:,3) = SAV%tol(:,3)*100.D0 - write(6,*) "Total number of matches saved:",SAV%nfit + SAV%tol(:,1) = SAV%tol(:,1)*100._real32 + SAV%tol(:,3) = SAV%tol(:,3)*100._real32 + write(*,*) "Total number of matches saved:",SAV%nfit !!!----------------------------------------------------------------------------- !!! Print the set of best matches !!!----------------------------------------------------------------------------- - if(present(lprint))then - if(lprint)then - do i=1,SAV%nfit - write(6,'(/,A,I0,2X,A,I0)') & - "Fit number: ",i,& - "Area increase: ",& - nint(get_area(dble(SAV%tf1(i,1,:)),dble(SAV%tf1(i,2,:)))) - write(6,'(" Transmat 1: Transmat 2:")') - write(6,'((/,1X,3(3X,A1),3X,3(3X,A1)))') SAV%abc,SAV%abc - write(6,'(3(/,2X,3(I3," "),3X,3(I3," ")))') & - SAV%tf1(i,1,1:3),SAV%tf2(i,1,1:3),& - SAV%tf1(i,2,1:3),SAV%tf2(i,2,1:3),& - SAV%tf1(i,3,1:3),SAV%tf2(i,3,1:3) - write(6,'(" vector mismatch (%) = ",F0.9)') SAV%tol(i,1) - write(6,'(" angle mismatch (°) = ",F0.9)') SAV%tol(i,2)*180/pi - write(6,'(" area mismatch (%) = ",F0.9)') SAV%tol(i,3) - write(6,*) "reduced:",lvec1(i) - write(6,*) - end do - end if + if(verbose.gt.0)then + do i=1,SAV%nfit + write(*,'(/,A,I0,2X,A,I0)') & + "Fit number: ",i,& + "Area increase: ",& + nint(get_area(real(SAV%tf1(i,1,:),real32),real(SAV%tf1(i,2,:),real32))) + write(*,'(" Transmat 1: Transmat 2:")') + write(*,'((/,1X,3(3X,A1),3X,3(3X,A1)))') SAV%abc,SAV%abc + write(*,'(3(/,2X,3(I3," "),3X,3(I3," ")))') & + SAV%tf1(i,1,1:3),SAV%tf2(i,1,1:3),& + SAV%tf1(i,2,1:3),SAV%tf2(i,2,1:3),& + SAV%tf1(i,3,1:3),SAV%tf2(i,3,1:3) + write(*,'(" vector mismatch (%) = ",F0.9)') SAV%tol(i,1) + write(*,'(" angle mismatch (°) = ",F0.9)') SAV%tol(i,2)*180/pi + write(*,'(" area mismatch (%) = ",F0.9)') SAV%tol(i,3) + write(*,*) "reduced:",lvec1(i) + write(*,*) + end do end if @@ -1407,16 +1275,16 @@ end subroutine lattice_matching ! function compensate_strains(tfmat,w_elastic_tensor,up_elastic_tensor) ! implicit none ! integer :: i -! double precision, dimension(3) :: strain_vec +! real(real32), dimension(3) :: strain_vec ! ! integer, intent(in) :: axis -! double precision, dimension(3,3), intent(in) :: lat1,lat2 -! double precision, dimension(6,6), intent(in) :: elastic_tensor +! real(real32), dimension(3,3), intent(in) :: lat1,lat2 +! real(real32), dimension(6,6), intent(in) :: elastic_tensor ! ! -! ident = 0.D0 +! ident = 0._real32 ! do i=1,3 -! ident(i,i) = 1.D0 +! ident(i,i) = 1._real32 ! end do ! ! do i=1,3 @@ -1448,12 +1316,12 @@ end subroutine lattice_matching ! function tester(lw_lat,up_lat,lw_tfmat,up_tfmat,lw_elastic,up_elastic) result(stress_vec) ! implicit none ! integer :: i -! double precision, dimension(6) :: strain_vec, stress_vec +! real(real32), dimension(6) :: strain_vec, stress_vec ! ! integer, intent(in) :: axis -! double precision, dimension(2,3), intent(in) :: lw_tfmat,up_tfmat -! double precision, dimension(3,3), intent(in) :: lw_lat,up_lat -! double precision, dimension(6,6), intent(in) :: lw_elastic,up_elastic +! real(real32), dimension(2,3), intent(in) :: lw_tfmat,up_tfmat +! real(real32), dimension(3,3), intent(in) :: lw_lat,up_lat +! real(real32), dimension(6,6), intent(in) :: lw_elastic,up_elastic ! ! ! ! turn lw_elastic and up_elastic into 3x3x3x3 matrices @@ -1469,18 +1337,18 @@ end subroutine lattice_matching ! lw_tflat = matmul(lw_lat,lw_tfmat) ! up_tflat = matmul(up_lat,up_tfmat) ! -! ident = 0.D0 +! ident = 0._real32 ! do i=1,3 -! ident(i,i) = 1.D0 +! ident(i,i) = 1._real32 ! end do ! ! strain_mat = matmul(lat1,inverse(lat2))-ident ! do i=1,3 ! strain_vec(i) = strain_mat(i,i) ! end do -! strain_vec(4) = 2.D0*strain_mat(2,3) -! strain_vec(5) = 2.D0*strain_mat(3,1) -! strain_vec(6) = 2.D0*strain_mat(1,2) +! strain_vec(4) = 2._real32*strain_mat(2,3) +! strain_vec(5) = 2._real32*strain_mat(3,1) +! strain_vec(6) = 2._real32*strain_mat(1,2) ! ! stress_vec = matmul(strain_vec,elastic_tensor) ! @@ -1504,25 +1372,25 @@ end subroutine lattice_matching ! function get_stress(lat1,lat2,axis,elastic_tensor) result(stress_vec) ! implicit none ! integer :: i -! double precision, dimension(6) :: strain_vec, stress_vec +! real(real32), dimension(6) :: strain_vec, stress_vec ! ! integer, intent(in) :: axis -! double precision, dimension(3,3), intent(in) :: lat1,lat2 -! double precision, dimension(6,6), intent(in) :: elastic_tensor +! real(real32), dimension(3,3), intent(in) :: lat1,lat2 +! real(real32), dimension(6,6), intent(in) :: elastic_tensor ! ! -! ident = 0.D0 +! ident = 0._real32 ! do i=1,3 -! ident(i,i) = 1.D0 +! ident(i,i) = 1._real32 ! end do ! ! strain_mat = matmul(lat1,inverse(lat2))-ident ! do i=1,3 ! strain_vec(i) = strain_mat(i,i) ! end do -! strain_vec(4) = 2.D0*strain_mat(2,3) -! strain_vec(5) = 2.D0*strain_mat(3,1) -! strain_vec(6) = 2.D0*strain_mat(1,2) +! strain_vec(4) = 2._real32*strain_mat(2,3) +! strain_vec(5) = 2._real32*strain_mat(3,1) +! strain_vec(6) = 2._real32*strain_mat(1,2) ! ! stress_vec = matmul(strain_vec,elastic_tensor) ! diff --git a/src/lib/mod_misc.f90 b/src/fortran/lib/mod_misc.f90 similarity index 67% rename from src/lib/mod_misc.f90 rename to src/fortran/lib/mod_misc.f90 index 3b45407..ba4ddef 100644 --- a/src/lib/mod_misc.f90 +++ b/src/fortran/lib/mod_misc.f90 @@ -5,8 +5,6 @@ !!!############################################################################# !!! module contains various miscellaneous functions and subroutines. !!! module includes the following functions and subroutines: -!!! closest_below (returns closest element below input number) -!!! closest_above (returns closest element above input number) !!! sort1D (sort 1st col of array by size. Opt:sort 2nd array wrt 1st) !!! sort2D (sort 1st two columns of an array by size) !!! set (return the sorted set of unique elements) @@ -16,9 +14,7 @@ !!! swap_vec (swap two vectors around) !!!################## !!! Icount (counts words on line) -!!! readcl (read string and separate into a char array using user fs) !!! grep (finds 1st line containing the pattern) -!!! count_occ (count number of occurances of substring in string) !!! flagmaker (read flag inputs supplied and stores variable if present) !!! loadbar (writes out a loading bar to the terminal) !!! jump (moves file to specified line number) @@ -26,78 +22,26 @@ !!! to_upper (converts all characters in string to upper case) !!! to_lower (converts all characters in string to lower case) !!!############################################################################# -module misc +module artemis__misc + use artemis__constants, only: real32 implicit none + interface swap + procedure iswap, rswap, rswap_vec + end interface swap + interface sort1D - procedure isort1D,rsort1D,dsort1D + procedure isort1D,rsort1D end interface sort1D interface set - procedure iset,rset,dset + procedure iset,rset end interface set -!!!updated 2021/12/08 - contains -!!!##################################################### -!!! function to find closest -ve element in array -!!!##################################################### - function closest_below(vec,val,optmask) result(int) - implicit none - integer :: i,int - double precision :: val,best,dtmp1 - double precision, dimension(:) :: vec - logical, dimension(:), optional :: optmask - - int=0 - best=-huge(0.D0) - do i=1,size(vec) - dtmp1=vec(i)-val - if(present(optmask))then - if(.not.optmask(i)) cycle - end if - if(dtmp1.gt.best.and.dtmp1.lt.-1.D-8)then - best=dtmp1 - int=i - end if - end do - - return - end function closest_below -!!!##################################################### - - -!!!##################################################### -!!! function to find closest +ve element in array -!!!##################################################### - function closest_above(vec,val,optmask) result(int) - implicit none - integer :: i,int - double precision :: val,best,dtmp1 - double precision, dimension(:) :: vec - logical, dimension(:), optional :: optmask - - int=0 - best=huge(0.D0) - do i=1,size(vec) - dtmp1=vec(i)-val - if(present(optmask))then - if(.not.optmask(i)) cycle - end if - if(dtmp1.lt.best.and.dtmp1.gt.1.D-8)then - best=dtmp1 - int=i - end if - end do - - return - end function closest_above -!!!##################################################### - !!!##################################################### !!! sorts two arrays from min to max @@ -143,46 +87,9 @@ end subroutine isort1D subroutine rsort1D(arr1,arr2,reverse) implicit none integer :: i,dim,loc,ibuff - real :: rbuff - logical :: udef_reverse - real, dimension(:) :: arr1 - integer, dimension(:),intent(inout),optional :: arr2 - logical, optional, intent(in) :: reverse - - if(present(reverse))then - udef_reverse=reverse - else - udef_reverse=.false. - end if - - dim=size(arr1,dim=1) - do i=1,dim - if(udef_reverse)then - loc=maxloc(arr1(i:dim),dim=1)+i-1 - else - loc=minloc(arr1(i:dim),dim=1)+i-1 - end if - rbuff=arr1(i) - arr1(i)=arr1(loc) - arr1(loc)=rbuff - - if(present(arr2)) then - ibuff=arr2(i) - arr2(i)=arr2(loc) - arr2(loc)=ibuff - end if - end do - - return - end subroutine rsort1D -!!!----------------------------------------------------- -!!!----------------------------------------------------- - subroutine dsort1D(arr1,arr2,reverse) - implicit none - integer :: i,dim,loc,ibuff - double precision :: dbuff + real(real32) :: dbuff logical :: udef_reverse - double precision, dimension(:) :: arr1 + real(real32), dimension(:) :: arr1 integer, dimension(:),intent(inout),optional :: arr2 logical, optional, intent(in) :: reverse @@ -211,7 +118,7 @@ subroutine dsort1D(arr1,arr2,reverse) end do return - end subroutine dsort1D + end subroutine rsort1D !!!##################################################### @@ -222,20 +129,20 @@ subroutine sort2D(arr,dim) implicit none integer :: i,j,dim,loc,istart integer, dimension(3) :: a123 - double precision, dimension(3) :: buff - double precision, dimension(dim,3) :: arr + real(real32), dimension(3) :: buff + real(real32), dimension(dim,3) :: arr - a123(:)=(/1,2,3/) + a123(:) = [ 1, 2, 3 ] istart=1 - do j=1,3 - do i=j,dim - loc=minloc(abs(arr(i:dim,a123(1))),dim=1,mask=(abs(arr(i:dim,a123(1))).gt.1.D-5))+i-1 + do j = 1, 3 + do i = j, dim + loc=minloc(abs(arr(i:dim,a123(1))),dim=1,mask=(abs(arr(i:dim,a123(1))).gt.1.E-5_real32))+i-1 buff(:)=arr(i,:) arr(i,:)=arr(loc,:) arr(loc,:)=buff(:) end do - scndrow: do i=j,dim + scndrow: do i = j, dim if(abs(arr(j,a123(1))).ne.abs(arr(i,a123(1)))) exit scndrow loc=minloc(abs(arr(i:dim,a123(2)))+abs(arr(i:dim,a123(3))),dim=1,& mask=(abs(arr(j,a123(1))).eq.abs(arr(i:dim,a123(1)))))+i-1 @@ -280,16 +187,16 @@ end subroutine iset subroutine rset(arr, tol) implicit none integer :: i,n - real :: tiny - real, allocatable, dimension(:) :: tmp_arr + real(real32) :: tiny + real(real32), allocatable, dimension(:) :: tmp_arr - real, allocatable, dimension(:) :: arr - real, optional :: tol + real(real32), allocatable, dimension(:) :: arr + real(real32), optional :: tol if(present(tol))then tiny = tol else - tiny = 1.E-4 + tiny = 1.E-4_real32 end if call sort1D(arr) @@ -305,36 +212,6 @@ subroutine rset(arr, tol) call move_alloc(tmp_arr, arr) end subroutine rset -!!!----------------------------------------------------- -!!!----------------------------------------------------- - subroutine dset(arr, tol) - implicit none - integer :: i,n - double precision :: tiny - double precision, allocatable, dimension(:) :: tmp_arr - - double precision, allocatable, dimension(:) :: arr - double precision, optional :: tol - - if(present(tol))then - tiny = tol - else - tiny = 1.D-4 - end if - - call sort1D(arr) - allocate(tmp_arr(size(arr))) - - tmp_arr(1) = arr(1) - n=1 - do i=2,size(arr) - if(abs(arr(i)-tmp_arr(n)).lt.tiny) cycle - n = n + 1 - tmp_arr(n) = arr(i) - end do - call move_alloc(tmp_arr, arr) - - end subroutine dset !!!##################################################### @@ -347,8 +224,8 @@ subroutine sort_col(arr1,col,reverse) implicit none integer :: i,dim,loc logical :: udef_reverse - double precision, allocatable, dimension(:) :: dbuff - double precision, dimension(:,:) :: arr1 + real(real32), allocatable, dimension(:) :: dbuff + real(real32), dimension(:,:) :: arr1 integer, intent(in) :: col logical, optional, intent(in) :: reverse @@ -383,44 +260,44 @@ end subroutine sort_col !!!##################################################### !!! swap two ints !!!##################################################### - subroutine swap_i(i1,i2) + subroutine iswap(i1,i2) implicit none integer :: i1,i2,itmp itmp=i1 i1=i2 i2=itmp - end subroutine swap_i + end subroutine iswap !!!##################################################### !!!##################################################### !!! swap two doubles !!!##################################################### - subroutine swap_d(d1,d2) + subroutine rswap(d1,d2) implicit none - double precision :: d1,d2,dtmp + real(real32) :: d1,d2,dtmp dtmp=d1 d1=d2 d2=dtmp - end subroutine swap_d + end subroutine rswap !!!##################################################### !!!##################################################### !!! swap two vectors !!!##################################################### - subroutine swap_vec(vec1,vec2) + subroutine rswap_vec(vec1,vec2) implicit none - double precision,dimension(:)::vec1,vec2 - double precision,allocatable,dimension(:)::tvec + real(real32),dimension(:)::vec1,vec2 + real(real32),allocatable,dimension(:)::tvec allocate(tvec(size(vec1))) tvec=vec1(:) vec1(:)=vec2(:) vec2(:)=tvec - end subroutine swap_vec + end subroutine rswap_vec !!!##################################################### @@ -467,52 +344,6 @@ end function Icount !!!##################################################### -!!!##################################################### -!!! counts the number of words on a line -!!!##################################################### - subroutine readcl(full_line,store,tmpchar) - character(*) :: full_line - !ONLY WORKS WITH IFORT COMPILER - ! character(1) :: fs - character(len=:),allocatable :: fs - character(*),optional :: tmpchar - character(100),dimension(1000) :: tmp_store - character(*),allocatable,dimension(:),optional :: store - integer ::items,pos,k,length - items=0 - pos=1 - - length=1 - if(present(tmpchar)) length=len(trim(tmpchar)) - allocate(character(len=length) :: fs) - if(present(tmpchar)) then - fs=tmpchar - else - fs=" " - end if - - loop: do - k=verify(full_line(pos:),fs) - if (k.eq.0) exit loop - pos=k+pos-1 - k=scan(full_line(pos:),fs) - if (k.eq.0) exit loop - items=items+1 - tmp_store(items)=full_line(pos:pos+k-1) - pos=k+pos-1 - end do loop - - if(present(store))then - if(.not.allocated(store)) allocate(store(items)) - do k=1,items - store(k)=trim(tmp_store(k)) - end do - end if - - end subroutine readcl -!!!##################################################### - - !!!##################################################### !!! grep !!!##################################################### @@ -532,32 +363,6 @@ end subroutine grep !!!##################################################### -!!!##################################################### -!!! count number of occurances of substring in string -!!!##################################################### - function count_occ(string,substring) - implicit none - integer :: pos,i,count_occ - character(*) :: string,substring - - pos=1 - count_occ=0 - countloop: do - i=verify(string(pos:), substring) - if (i.eq.0) exit countloop - if(pos.eq.len(string)) exit countloop - count_occ=count_occ+1 - pos=i+pos-1 - i=scan(string(pos:), ' ') - if (i.eq.0) exit countloop - pos=i+pos-1 - end do countloop - - return - end function count_occ -!!!##################################################### - - !!!##################################################### !!! Assigns variables of flags from getarg !!!##################################################### @@ -590,7 +395,7 @@ end subroutine flagmaker subroutine loadbar(count,div,loaded) implicit none integer :: count,div !div=10 - real :: tiny=1.E-5 + real(real32) :: tiny=1.E-5 character(1) :: yn,creturn = achar(13) character(1), optional :: loaded @@ -606,9 +411,9 @@ subroutine loadbar(count,div,loaded) end if if((real(count)/real(4*div)-floor(real(count)/real(4*div))).lt.tiny) then - write(6,'(A,20X,A,"CALCULATING")',advance='no') creturn,creturn + write(*,'(A,20X,A,"CALCULATING")',advance='no') creturn,creturn else if((real(count)/real(div)-floor(real(count)/real(div))).lt.tiny) then - write(6,'(".")',advance='no') + write(*,'(".")',advance='no') end if return @@ -647,22 +452,22 @@ subroutine file_check(UNIT,FILENAME,ACTION) do i=1,5 inquire(file=trim(FILENAME),exist=filefound) if(.not.filefound) then - write(6,'("File name ",A," not found.")')& + write(*,'("File name ",A," not found.")')& "'"//trim(FILENAME)//"'" - write(6,'("Supply another filename: ")') + write(*,'("Supply another filename: ")') read(*,*) FILENAME else - write(6,'("Using file ",A)') & + write(*,'("Using file ",A)') & "'"//trim(FILENAME)//"'" exit end if if(i.ge.4) then - write(6,*) "Nope" + write(*,*) "Nope" call exit() end if end do if(trim(adjustl(udef_action)).eq.'NONE')then - write(6,*) "File found, but not opened." + write(*,*) "File found, but not opened." else open(unit=UNIT,file=trim(FILENAME),action=trim(udef_action),iostat=Reason) end if @@ -722,4 +527,37 @@ function to_lower(buffer) result(lower) end function to_lower !!!##################################################### -end module misc + +!############################################################################### + function strip_null(buffer) result(stripped) + !! Strip null characters from a string. + !! + !! This is meant for handling strings passed from Python, which gain + !! null characters at the end. The procedure finds the first null + !! character and truncates the string at that point. + !! Null characters are represented by ASCII code 0. + implicit none + + ! Arguments + character(*), intent(in) :: buffer + !! String to be stripped. + character(len=len(buffer)) :: stripped + !! Stripped string. + + ! Local variables + integer :: i + !! Loop index. + + stripped = "" + do i = 1, len(buffer) + if(iachar(buffer(i:i)).ne.0)then + stripped(i:i)=buffer(i:i) + else + exit + end if + end do + + end function strip_null +!############################################################################### + +end module artemis__misc diff --git a/src/lib/mod_misc_linalg.f90 b/src/fortran/lib/mod_misc_linalg.f90 similarity index 73% rename from src/lib/mod_misc_linalg.f90 rename to src/fortran/lib/mod_misc_linalg.f90 index 5fd9467..1dc28c0 100644 --- a/src/lib/mod_misc_linalg.f90 +++ b/src/fortran/lib/mod_misc_linalg.f90 @@ -40,25 +40,10 @@ !!! gen_group (generate group from a subset of elements) !!!############################################################################# module misc_linalg + use artemis__constants, only: real32 implicit none integer, parameter, private :: QuadInt_K = selected_int_kind (16) - interface uvec - procedure ruvec,duvec - end interface uvec - - interface modu - procedure rmodu,dmodu - end interface modu - - interface proj - procedure rproj,dproj - end interface proj - - interface cross - procedure rcross,dcross - end interface cross - interface gcd procedure gcd_vec,gcd_num end interface gcd @@ -80,42 +65,25 @@ module misc_linalg !!!##################################################### !!! finds unit vector of an arbitrary vector !!!##################################################### - function ruvec(vec) result(uvec) + function uvec(vec) result(output) implicit none - real,dimension(:)::vec - real,allocatable,dimension(:)::uvec - allocate(uvec(size(vec))) - uvec=vec/rmodu(vec) - end function ruvec -!!!----------------------------------------------------- -!!!----------------------------------------------------- - function duvec(vec) result(uvec) - implicit none - double precision,dimension(:)::vec - double precision,allocatable,dimension(:)::uvec - allocate(uvec(size(vec))) - uvec=vec/dmodu(vec) - end function duvec + real(real32),dimension(:)::vec + real(real32),allocatable,dimension(:) :: output + allocate(output(size(vec))) + output = vec/modu(vec) + end function uvec !!!##################################################### !!!##################################################### !!! finds modulus of an arbitrary length vector !!!##################################################### - function rmodu(vec) result(modu) + function modu(vec) result(output) implicit none - real,dimension(:)::vec - real::modu - modu=abs(sqrt(sum(vec(:)**2))) - end function rmodu -!!!----------------------------------------------------- -!!!----------------------------------------------------- - function dmodu(vec) result(modu) - implicit none - double precision,dimension(:)::vec - double precision::modu - modu=abs(sqrt(sum(vec(:)**2))) - end function dmodu + real(real32),dimension(:)::vec + real(real32)::output + output = abs(sqrt(sum(vec(:)**2))) + end function modu !!!##################################################### @@ -123,26 +91,15 @@ end function dmodu !!! projection operator !!!##################################################### !!! projection of v on u - function rproj(u,v) result(proj) - implicit none - real, dimension(:) :: u,v - real, allocatable, dimension(:) :: proj - - allocate(proj(size(u,dim=1))) - proj = u*dot_product(v,u)/dot_product(u,u) - - end function rproj -!!!----------------------------------------------------- -!!!----------------------------------------------------- - function dproj(u,v) result(proj) + function proj(u,v) result(output) implicit none - double precision, dimension(:) :: u,v - double precision, allocatable, dimension(:) :: proj + real(real32), dimension(:) :: u,v + real(real32), allocatable, dimension(:) :: output - allocate(proj(size(u,dim=1))) - proj = u*dot_product(v,u)/dot_product(u,u) + allocate(output(size(u,dim=1))) + output = u*dot_product(v,u)/dot_product(u,u) - end function dproj + end function proj !!!##################################################### @@ -155,9 +112,9 @@ end function dproj function GramSchmidt(basis,normalise,cmo) result(u) implicit none integer :: num,dim,i,j - double precision, allocatable, dimension(:) :: vtmp - double precision, dimension(:,:), intent(in) :: basis - double precision, allocatable, dimension(:,:) :: u + real(real32), allocatable, dimension(:) :: vtmp + real(real32), dimension(:,:), intent(in) :: basis + real(real32), allocatable, dimension(:,:) :: u logical, optional, intent(in) :: cmo logical, optional, intent(in) :: normalise @@ -184,7 +141,7 @@ function GramSchmidt(basis,normalise,cmo) result(u) !! Evaluates the Gram-Schmidt basis u(1,:) = basis(1,:) do i=2,num - vtmp = 0.D0 + vtmp = 0._real32 do j=1,i-1,1 vtmp(:) = vtmp(:) + proj(u(j,:),basis(i,:)) end do @@ -209,28 +166,16 @@ end function GramSchmidt !!!##################################################### !!! cross product !!!##################################################### - pure function rcross(a,b) result(cross) - implicit none - real, dimension(3) :: cross - real, dimension(3), intent(in) :: a,b - - cross(1) = a(2)*b(3) - a(3)*b(2) - cross(2) = a(3)*b(1) - a(1)*b(3) - cross(3) = a(1)*b(2) - a(2)*b(1) - - end function rcross -!!!----------------------------------------------------- -!!!----------------------------------------------------- - pure function dcross(a,b) result(cross) + pure function cross(a,b) result(output) implicit none - double precision, dimension(3) :: cross - double precision, dimension(3), intent(in) :: a,b + real(real32), dimension(3) :: output + real(real32), dimension(3), intent(in) :: a,b - cross(1) = a(2)*b(3) - a(3)*b(2) - cross(2) = a(3)*b(1) - a(1)*b(3) - cross(3) = a(1)*b(2) - a(2)*b(1) + output(1) = a(2)*b(3) - a(3)*b(2) + output(2) = a(3)*b(1) - a(1)*b(3) + output(3) = a(1)*b(2) - a(2)*b(1) - end function dcross + end function cross !!!##################################################### @@ -245,10 +190,10 @@ end function dcross !!!##################################################### function cross_matrix(a) implicit none - double precision, dimension(3,3) :: cross_matrix - double precision, dimension(3), intent(in) :: a + real(real32), dimension(3,3) :: cross_matrix + real(real32), dimension(3), intent(in) :: a - cross_matrix=0.D0 + cross_matrix=0._real32 cross_matrix(1,2) = -a(3) cross_matrix(1,3) = a(2) @@ -269,8 +214,8 @@ end function cross_matrix function outer_product(a,b) implicit none integer :: j - double precision, dimension(:) :: a,b - double precision,allocatable,dimension(:,:)::outer_product + real(real32), dimension(:) :: a,b + real(real32),allocatable,dimension(:,:)::outer_product allocate(outer_product(size(a),size(b))) @@ -290,13 +235,13 @@ function ivec_dmat_mul(a,mat) result(vec) implicit none integer :: j integer, dimension(:) :: a - double precision, dimension(:,:) :: mat - double precision,allocatable,dimension(:) :: vec + real(real32), dimension(:,:) :: mat + real(real32),allocatable,dimension(:) :: vec - vec=0.D0 + vec=0._real32 allocate(vec(size(a))) do j=1,size(a) - vec(:)=vec(:)+dble(a(j))*mat(j,:) + vec(:)=vec(:)+real(a(j),real32)*mat(j,:) end do return @@ -306,11 +251,11 @@ end function ivec_dmat_mul function dvec_dmat_mul(a,mat) result(vec) implicit none integer :: j - double precision, dimension(:) :: a - double precision, dimension(:,:) :: mat - double precision,allocatable,dimension(:) :: vec + real(real32), dimension(:) :: a + real(real32), dimension(:,:) :: mat + real(real32),allocatable,dimension(:) :: vec - vec=0.D0 + vec=0._real32 allocate(vec(size(a))) do j=1,size(a) vec(:)=vec(:)+a(j)*mat(j,:) @@ -327,21 +272,21 @@ end function dvec_dmat_mul function get_vec_multiple(a,b) result(multi) implicit none integer :: i - double precision :: multi - double precision, dimension(:) :: a,b + real(real32) :: multi + real(real32), dimension(:) :: a,b - multi=1.D0 + multi=1._real32 do i=1,size(a) - if(a(i).eq.0.D0.or.b(i).eq.0.D0) cycle + if(abs(a(i)).lt.1.E-6_real32.or.abs(b(i)).lt.1.E-6_real32) cycle multi=b(i)/a(i) exit end do checkloop: do i=1,size(a) - if(a(i).eq.0.D0.or.b(i).eq.0.D0) cycle - if(abs(a(i)*multi-b(i)).gt.1.D-8)then + if(abs(a(i)).lt.1.E-6_real32.or.abs(b(i)).lt.1.E-6_real32) cycle + if(abs(a(i)*multi-b(i)).gt.1.E-6_real32)then - multi=0.D0 + multi=0._real32 exit checkloop end if end do checkloop @@ -363,12 +308,12 @@ end function get_vec_multiple !!!##################################################### function get_angle(vec1,vec2) result(angle) implicit none - double precision :: angle - double precision, dimension(3) :: vec1,vec2 + real(real32) :: angle + real(real32), dimension(3) :: vec1,vec2 angle = acos( dot_product(vec1,vec2)/& ( modu(vec1) * modu(vec2) )) - if (isnan(angle)) angle = 0.D0 + if (isnan(angle)) angle = 0._real32 return end function get_angle @@ -380,8 +325,8 @@ end function get_angle !!!##################################################### function get_area(a,b) result(area) implicit none - double precision :: area - double precision, dimension(3) :: vec,a,b + real(real32) :: area + real(real32), dimension(3) :: vec,a,b vec = cross(a,b) area = sqrt(dot_product(vec,vec)) @@ -397,21 +342,21 @@ end function get_area function get_vol(lat) result(vol) implicit none integer :: n,i,j,k,l - double precision :: vol,scale - double precision, dimension(3,3) :: lat - double precision, dimension(3) :: a,b,c + real(real32) :: vol,scale + real(real32), dimension(3,3) :: lat + real(real32), dimension(3) :: a,b,c a=lat(1,:) b=lat(2,:) c=lat(3,:) - vol = 0.D0;scale = 1.D0 + vol = 0._real32;scale = 1._real32 i=1;j=2;k=3 1 do n=1,3 vol = vol+scale*a(i)*b(j)*c(k) l=i;i=j;j=k;k=l end do i=2;j=1;k=3;scale=-scale - if(scale<0.D0) goto 1 + if(scale<0._real32) goto 1 return end function get_vol @@ -421,12 +366,13 @@ end function get_vol !!!##################################################### !!! finds trace of an arbitrary dimension square matrix !!!##################################################### - function trace(mat) + function trace(mat) result(output) integer::j - double precision,dimension(:,:)::mat - double precision::trace - do j=1,size(mat,1) - trace=trace+mat(j,j) + real(real32), dimension(:,:), intent(in) :: mat + real(real32) :: output + output = 0._real32 + do j = 1, size(mat,1) + output = output + mat(j,j) end do end function trace !!!##################################################### @@ -435,22 +381,22 @@ end function trace !!!##################################################### !!! returns determinant of 3 x 3 matrix !!!##################################################### - function idet(mat) result(det) - integer :: det - integer, dimension(3,3) :: mat + function idet(mat) result(output) + integer :: output + integer, dimension(3,3), intent(in) :: mat - det=mat(1,1)*mat(2,2)*mat(3,3)-mat(1,1)*mat(2,3)*mat(3,2)& + output = mat(1,1)*mat(2,2)*mat(3,3)-mat(1,1)*mat(2,3)*mat(3,2)& - mat(1,2)*mat(2,1)*mat(3,3)+mat(1,2)*mat(2,3)*mat(3,1)& + mat(1,3)*mat(2,1)*mat(3,2)-mat(1,3)*mat(2,2)*mat(3,1) end function idet !!!----------------------------------------------------- !!!----------------------------------------------------- - function ddet(mat) result(det) - double precision :: det - double precision, dimension(3,3) :: mat + function ddet(mat) result(output) + real(real32) :: output + real(real32), dimension(3,3), intent(in) :: mat - det=mat(1,1)*mat(2,2)*mat(3,3)-mat(1,1)*mat(2,3)*mat(3,2)& + output = mat(1,1)*mat(2,2)*mat(3,3)-mat(1,1)*mat(2,3)*mat(3,2)& - mat(1,2)*mat(2,1)*mat(3,3)+mat(1,2)*mat(2,3)*mat(3,1)& + mat(1,3)*mat(2,1)*mat(3,2)-mat(1,3)*mat(2,2)*mat(3,1) @@ -462,14 +408,15 @@ end function ddet !!! returns inverse of 2x2 or 3x3 matrix !!!##################################################### pure function inverse(mat) - double precision, dimension(:,:), intent(in) :: mat - double precision, dimension(size(mat(:,1),dim=1),size(mat(1,:),dim=1)) :: inverse + real(real32), dimension(:,:), intent(in) :: mat + real(real32), dimension(size(mat,dim=1),size(mat,dim=2)) :: inverse - if(size(mat(1,:),dim=1).eq.2)then - inverse=inverse_2x2(mat) - elseif(size(mat(1,:),dim=1).eq.3)then - inverse=inverse_3x3(mat) - end if + select case(size(mat,dim=2)) + case(2) + inverse = inverse_2x2(mat) + case(3) + inverse = inverse_3x3(mat) + end select end function inverse !!!##################################################### @@ -478,23 +425,20 @@ end function inverse !!!##################################################### !!! returns inverse of 2 x 2 matrix !!!##################################################### - pure function inverse_2x2(mat) result(inverse) - double precision :: det - double precision, dimension(2,2) :: inverse - double precision, dimension(2,2), intent(in) :: mat + pure function inverse_2x2(mat) result(output) + implicit none + real(real32), dimension(2,2), intent(in) :: mat + real(real32), dimension(2,2) :: output + real(real32) :: inv_det - det=mat(1,1)*mat(2,2)-mat(1,2)*mat(2,1) - !if(det.eq.0.D0)then - ! write(0,'("ERROR: Internal error in inverse_2x2")') - ! write(0,'(2X,"inverse_2x2 in mod_misc_linalg found determinant of 0")') - ! write(0,'(2X,"Exiting...")') - ! stop - !end if + associate(a => mat(1,1), b => mat(1,2), c => mat(2,1), d => mat(2,2)) + inv_det = 1._real32 / (a * d - b * c) - inverse(1,1)=+1.D0/det*(mat(2,2)) - inverse(2,1)=-1.D0/det*(mat(1,2)) - inverse(1,2)=-1.D0/det*(mat(2,1)) - inverse(2,2)=+1.D0/det*(mat(1,1)) + output(1,1) = d * inv_det + output(1,2) = -b * inv_det + output(2,1) = -c * inv_det + output(2,2) = a * inv_det + end associate end function inverse_2x2 !!!##################################################### @@ -503,33 +447,48 @@ end function inverse_2x2 !!!##################################################### !!! returns inverse of 3 x 3 matrix !!!##################################################### - pure function inverse_3x3(mat) result(inverse) - double precision :: det - double precision, dimension(3,3) :: inverse - double precision, dimension(3,3), intent(in) :: mat + pure function inverse_3x3(mat) result(output) + implicit none + real(real32), dimension(3,3), intent(in) :: mat + real(real32), dimension(3,3) :: output + real(real32) :: inv_det + real(real32) :: c00, c01, c02, c10, c11, c12, c20, c21, c22 - det=mat(1,1)*mat(2,2)*mat(3,3)-mat(1,1)*mat(2,3)*mat(3,2)& - - mat(1,2)*mat(2,1)*mat(3,3)+mat(1,2)*mat(2,3)*mat(3,1)& - + mat(1,3)*mat(2,1)*mat(3,2)-mat(1,3)*mat(2,2)*mat(3,1) + associate( & + m11 => mat(1,1), m12 => mat(1,2), m13 => mat(1,3), & + m21 => mat(2,1), m22 => mat(2,2), m23 => mat(2,3), & + m31 => mat(3,1), m32 => mat(3,2), m33 => mat(3,3)) + + ! Cofactors + c00 = m22 * m33 - m23 * m32 + c01 = -m21 * m33 + m23 * m31 + c02 = m21 * m32 - m22 * m31 - !if(det.eq.0.D0)then - ! write(0,'("ERROR: Internal error in inverse_3x3")') - ! write(0,'(2X,"inverse_3x3 in mod_misc_linalg found determinant of 0")') - ! write(0,'(2X,"Exiting...")') - ! stop - !end if + c10 = -m12 * m33 + m13 * m32 + c11 = m11 * m33 - m13 * m31 + c12 = -m11 * m32 + m12 * m31 - inverse(1,1)=+1.D0/det*(mat(2,2)*mat(3,3)-mat(2,3)*mat(3,2)) - inverse(2,1)=-1.D0/det*(mat(2,1)*mat(3,3)-mat(2,3)*mat(3,1)) - inverse(3,1)=+1.D0/det*(mat(2,1)*mat(3,2)-mat(2,2)*mat(3,1)) - inverse(1,2)=-1.D0/det*(mat(1,2)*mat(3,3)-mat(1,3)*mat(3,2)) - inverse(2,2)=+1.D0/det*(mat(1,1)*mat(3,3)-mat(1,3)*mat(3,1)) - inverse(3,2)=-1.D0/det*(mat(1,1)*mat(3,2)-mat(1,2)*mat(3,1)) - inverse(1,3)=+1.D0/det*(mat(1,2)*mat(2,3)-mat(1,3)*mat(2,2)) - inverse(2,3)=-1.D0/det*(mat(1,1)*mat(2,3)-mat(1,3)*mat(2,1)) - inverse(3,3)=+1.D0/det*(mat(1,1)*mat(2,2)-mat(1,2)*mat(2,1)) + c20 = m12 * m23 - m13 * m22 + c21 = -m11 * m23 + m13 * m21 + c22 = m11 * m22 - m12 * m21 - end function inverse_3x3 + inv_det = 1._real32 / (m11 * c00 + m12 * c01 + m13 * c02) + + ! Transpose cofactors into the inverse + output(1,1) = c00 * inv_det + output(2,1) = c01 * inv_det + output(3,1) = c02 * inv_det + + output(1,2) = c10 * inv_det + output(2,2) = c11 * inv_det + output(3,2) = c12 * inv_det + + output(1,3) = c20 * inv_det + output(2,3) = c21 * inv_det + output(3,3) = c22 * inv_det + + end associate +end function inverse_3x3 !!!##################################################### @@ -538,15 +497,15 @@ end function inverse_3x3 !!!##################################################### recursive function rec_det(a,n) result(res) integer :: i, sign - double precision :: res + real(real32) :: res integer, intent(in) :: n - double precision, dimension(n,n), intent(in) :: a - double precision, dimension(n-1, n-1) :: tmp + real(real32), dimension(n,n), intent(in) :: a + real(real32), dimension(n-1, n-1) :: tmp if(n.eq.1) then res = a(1,1) else - res = 0.D0 + res = 0._real32 sign = 1 do i=1, n tmp(:,:(i-1))=a(2:,:i-1) @@ -572,16 +531,16 @@ end function rec_det function LUdet(inmat) implicit none integer :: i,N - double precision :: LUdet - double precision, dimension(:,:) :: inmat - double precision, dimension(size(inmat,1),size(inmat,1)) :: L,U + real(real32) :: LUdet + real(real32), dimension(:,:) :: inmat + real(real32), dimension(size(inmat,1),size(inmat,1)) :: L,U - L=0.D0 - U=0.D0 + L=0._real32 + U=0._real32 N=size(inmat,1) call LUdecompose(inmat,L,U) - LUdet=(-1.D0)**N + LUdet=(-1._real32)**N do i=1,N LUdet=LUdet*L(i,i)*U(i,i) end do @@ -605,13 +564,13 @@ end function LUdet function LUinv(inmat) implicit none integer :: i,m,N - double precision, dimension(:,:) :: inmat - double precision, dimension(size(inmat,1),size(inmat,1)) :: LUinv - double precision, dimension(size(inmat,1),size(inmat,1)) :: L,U - double precision, dimension(size(inmat,1)) :: c,z,x + real(real32), dimension(:,:) :: inmat + real(real32), dimension(size(inmat,1),size(inmat,1)) :: LUinv + real(real32), dimension(size(inmat,1),size(inmat,1)) :: L,U + real(real32), dimension(size(inmat,1)) :: c,z,x - L=0.D0 - U=0.D0 + L=0._real32 + U=0._real32 N=size(inmat,1) call LUdecompose(inmat,L,U) @@ -619,8 +578,8 @@ function LUinv(inmat) !!! c are column vectors of the identity matrix !!! uses forward substitution to solve do m=1,N - c=0.D0 - c(m)=1.D0 + c=0._real32 + c(m)=1._real32 z(1)=c(1) do i=2,N @@ -656,16 +615,16 @@ end function LUinv subroutine LUdecompose(inmat,L,U) implicit none integer :: i,j,N - double precision, dimension(:,:) :: inmat,L,U - double precision, dimension(size(inmat,1),size(inmat,1)) :: mat + real(real32), dimension(:,:) :: inmat,L,U + real(real32), dimension(size(inmat,1),size(inmat,1)) :: mat N=size(inmat,1) mat=inmat - L=0.D0 - U=0.D0 + L=0._real32 + U=0._real32 do j=1,N - L(j,j)=1.D0 + L(j,j)=1._real32 end do !!! Solves the lower matrix do j=1,N-1 @@ -703,14 +662,20 @@ end subroutine LUdecompose !!!##################################################### function find_tf(mat1,mat2) result(tf) implicit none - double precision, dimension(:,:) :: mat1,mat2 - double precision, allocatable, dimension(:,:) :: tf + real(real32), dimension(:,:) :: mat1,mat2 + real(real32), dimension(size(mat1,dim=1),size(mat1,dim=2)) :: tf - allocate(tf(size(mat2(:,1),dim=1),size(mat1(1,:),dim=1))) tf=matmul(inverse(mat1),mat2) - end function find_tf + function find_tf_2x2(mat1,mat2) result(tf) + implicit none + real(real32), dimension(2,2) :: mat1,mat2 + real(real32), dimension(2,2) :: tf + + tf=matmul(inverse_2x2(mat1),mat2) + + end function find_tf_2x2 !!!##################################################### @@ -729,25 +694,25 @@ end function find_tf !!! hence, qA=qY P^-1 function simeq(qX,qY) integer :: i,j,n,loc - double precision, dimension(:) :: qX,qY - double precision, dimension(size(qY)) :: funcY - double precision, dimension(size(qY)) :: simeq,tmpqY - double precision, dimension(size(qY),size(qY)) :: P,invP,tmpP + real(real32), dimension(:) :: qX,qY + real(real32), dimension(size(qY)) :: funcY + real(real32), dimension(size(qY)) :: simeq,tmpqY + real(real32), dimension(size(qY),size(qY)) :: P,invP,tmpP n=size(qX) funcy=qY - P=0.D0 + P=0._real32 do i=1,n do j=1,n - P(i,j)=(qX(i)**dble(n-j)) + P(i,j)=(qX(i)**real(n-j,real32)) end do end do ! P(1,1)=qX(1)**2 ;P(1,2)=qX(1) ;P(1,3)=1.0; ! P(2,1)=qX(2)**2 ;P(2,2)=qX(2) ;P(2,3)=1.0; ! P(3,2)=qX(3)**2 ;P(3,2)=qX(3) ;P(3,3)=1.0; - if(any(qX.lt.1.D-5)) then + if(any(qX.lt.1.E-5_real32)) then loc=minloc(abs(qX),dim=1) tmpqY=funcY tmpP=P @@ -759,7 +724,7 @@ function simeq(qX,qY) ! invP=inverse(P) invP=LUinv((P)) - ! invP=LUinv(dble(P)) + ! invP=LUinv(real(P,real32)) simeq=matmul(invP,funcY) end function simeq @@ -775,19 +740,19 @@ end function simeq function LLL_reduce(basis,delta) result(obas) implicit none integer :: num,dim,i,j,k,loc - double precision :: d,dtmp - double precision, allocatable, dimension(:) :: vtmp,mag_bas - double precision, allocatable, dimension(:,:) :: mu,GSbas,obas + real(real32) :: d,dtmp + real(real32), allocatable, dimension(:) :: vtmp,mag_bas + real(real32), allocatable, dimension(:,:) :: mu,GSbas,obas - double precision, dimension(:,:), intent(in) :: basis - double precision, optional, intent(in) :: delta + real(real32), dimension(:,:), intent(in) :: basis + real(real32), optional, intent(in) :: delta !! set up the value for delta if(present(delta))then d = delta else - d = 0.75D0 + d = 0.75_real32 end if !! allocate and initialise arrays @@ -830,7 +795,7 @@ function LLL_reduce(basis,delta) result(obas) do while(k.le.num) jloop: do j=k-1,1!,-1 - if(abs(mu(k,j)).lt.0.5D0)then + if(abs(mu(k,j)).lt.0.5_real32)then obas(k,:) = obas(k,:) - & nint(mu(k,j))*obas(j,:) !! only need to update GSbas(k:,:) and mu @@ -841,7 +806,7 @@ function LLL_reduce(basis,delta) result(obas) end do jloop if(dot_product(GSbas(k,:),GSbas(k,:)).ge.& - (d - mu(k,k-1)**2.D0)*& + (d - mu(k,k-1)**2._real32)*& dot_product(GSbas(k-1,:),GSbas(k-1,:)) )then k = k + 1 else @@ -867,7 +832,7 @@ function LLL_reduce(basis,delta) result(obas) function get_mu(bas1,bas2) result(mu) implicit none integer :: num1,num2 - double precision, allocatable, dimension(:,:) :: mu,bas1,bas2 + real(real32), allocatable, dimension(:,:) :: mu,bas1,bas2 num1 = size(bas1(:,1),dim=1) num2 = size(bas2(:,1),dim=1) @@ -888,10 +853,10 @@ end function get_mu subroutine update_GS_and_mu(GSbas,mu,basis,k) implicit none integer :: num,dim,i,j - double precision, allocatable, dimension(:) :: vtmp + real(real32), allocatable, dimension(:) :: vtmp integer, intent(in) :: k - double precision, allocatable, dimension(:,:) :: GSbas,basis,mu + real(real32), allocatable, dimension(:,:) :: GSbas,basis,mu num = size(basis(:,1),dim=1) dim = size(basis(1,:),dim=1) @@ -900,7 +865,7 @@ subroutine update_GS_and_mu(GSbas,mu,basis,k) !!update Gram-Schmidt vectors do i=k,num,1 - vtmp = 0.D0 + vtmp = 0._real32 do j=1,i-1,1 vtmp(:) = vtmp(:) + proj(GSbas(j,:),basis(i,:)) end do @@ -933,25 +898,25 @@ end function LLL_reduce !!!##################################################### function rotvec(a,theta,phi,psi,new_length) implicit none - double precision :: magold,theta,phi,psi - double precision, dimension(3) :: a,rotvec - double precision, dimension(3,3) :: rotmat,rotmatx,rotmaty,rotmatz - double precision, optional :: new_length + real(real32) :: magold,theta,phi,psi + real(real32), dimension(3) :: a,rotvec + real(real32), dimension(3,3) :: rotmat,rotmatx,rotmaty,rotmatz + real(real32), optional :: new_length - ! if(phi.ne.0.D0) phi=-phi + ! if(phi.ne.0._real32) phi=-phi rotmatx=reshape((/& - 1.D0, 0.D0, 0.D0, & - 0.D0, cos(theta), -sin(theta),& - 0.D0, sin(theta), cos(theta)/), shape(rotmatx)) + 1._real32, 0._real32, 0._real32, & + 0._real32, cos(theta), -sin(theta),& + 0._real32, sin(theta), cos(theta)/), shape(rotmatx)) rotmaty=reshape((/& - cos(phi), 0.D0, sin(phi),& - 0.D0, 1.D0, 0.D0, & - -sin(phi), 0.D0, cos(phi)/), shape(rotmaty)) + cos(phi), 0._real32, sin(phi),& + 0._real32, 1._real32, 0._real32, & + -sin(phi), 0._real32, cos(phi)/), shape(rotmaty)) rotmatz=reshape((/& - cos(psi), -sin(psi), 0.D0,& - sin(psi), cos(psi), 0.D0, & - 0.D0, 0.D0, 1.D0/), shape(rotmatz)) + cos(psi), -sin(psi), 0._real32,& + sin(psi), cos(psi), 0._real32, & + 0._real32, 0._real32, 1._real32/), shape(rotmatz)) rotmat=matmul(rotmaty,rotmatx) @@ -974,13 +939,13 @@ end function rotvec function rot_arb_lat(a,lat,ang) result(vec) implicit none integer :: i - double precision, dimension(3) :: a,u,ang,vec - double precision, dimension(3,3) :: rotmat,ident,lat + real(real32), dimension(3) :: a,u,ang,vec + real(real32), dimension(3,3) :: rotmat,ident,lat - ident=0.D0 + ident=0._real32 do i=1,3 - ident(i,i)=1.D0 + ident(i,i)=1._real32 end do vec=a @@ -1096,17 +1061,17 @@ end function lcm integer function get_frac_denom(val) implicit none integer :: i - double precision :: val - double precision :: a,b,c,tiny + real(real32) :: val + real(real32) :: a,b,c,tiny - a=mod(val,1.D0) - b=1.D0 - tiny=1.D-6 + a=mod(val,1._real32) + b=1._real32 + tiny = 1.E-6_real32 i=0 do i=i+1 - if(abs(nint(1.D0/a)-(1.D0/a)).lt.tiny.and.& - abs(nint(val*1.D0/a)-val*(1.D0/a)).lt.tiny) exit + if(abs(nint(1._real32/a)-(1._real32/a)).lt.tiny.and.& + abs(nint(val*1._real32/a)-val*(1._real32/a)).lt.tiny) exit c=abs(b-a) b=a a=c @@ -1116,7 +1081,7 @@ integer function get_frac_denom(val) end if end do - get_frac_denom=nint(1.D0/a) + get_frac_denom=nint(1._real32/a) return end function get_frac_denom @@ -1129,14 +1094,14 @@ end function get_frac_denom function reduce_vec_gcd(invec) result(vec) implicit none integer :: i,a - double precision :: div,old_div,tol - double precision, allocatable, dimension(:) :: vec,tvec - double precision, dimension(:), intent(in) :: invec + real(real32) :: div,old_div,tol + real(real32), allocatable, dimension(:) :: vec,tvec + real(real32), dimension(:), intent(in) :: invec !!! MAKE IT DO SOMETHING IF IT CANNOT FULLY INTEGERISE - tol=1.D-5 + tol=1.E-5_real32 allocate(vec(size(invec))) vec=invec if(any(abs(vec(:)-nint(vec(:))).gt.tol))then @@ -1163,7 +1128,7 @@ function reduce_vec_gcd(invec) result(vec) div=a end if - if(div.eq.0.D0) return + if(div.eq.0._real32) return allocate(tvec(size(invec))) tvec=vec/div if(any(abs(tvec(:)-nint(tvec(:))).gt.tol)) return @@ -1180,20 +1145,20 @@ end function reduce_vec_gcd function gen_group(elem,mask,tol) result(group) implicit none integer :: i,j,k,nelem,ntot_elem,dim1,dim2,iter - double precision :: tiny - double precision, allocatable, dimension(:,:) :: tmp_elem,cur_elem,apply_elem - double precision, allocatable, dimension(:,:,:) :: tmp_group + real(real32) :: tiny + real(real32), allocatable, dimension(:,:) :: tmp_elem,cur_elem,apply_elem + real(real32), allocatable, dimension(:,:,:) :: tmp_group - double precision, dimension(:,:,:), intent(in) :: elem + real(real32), dimension(:,:,:), intent(in) :: elem logical, dimension(:,:), optional, intent(in) :: mask - double precision, allocatable, dimension(:,:,:) :: group - double precision, optional, intent(in) :: tol + real(real32), allocatable, dimension(:,:,:) :: group + real(real32), optional, intent(in) :: tol if(present(tol))then tiny = tol else - tiny = 1.D-5 + tiny = 1.E-5_real32 end if nelem = size(elem(:,1,1)) dim1 = size(elem(1,:,1)) @@ -1213,7 +1178,7 @@ function gen_group(elem,mask,tol) result(group) !write(0,'(2(2X,F9.6))') cur_elem(:,:) !write(0,*) if(present(mask))then - where(mask.and.(cur_elem(:,:).lt.-tiny.or.cur_elem(:,:).ge.1.D0-tiny)) + where(mask.and.(cur_elem(:,:).lt.-tiny.or.cur_elem(:,:).ge.1._real32-tiny)) cur_elem(:,:) = cur_elem(:,:) - floor(cur_elem(:,:)+tiny) end where end if @@ -1237,7 +1202,7 @@ function gen_group(elem,mask,tol) result(group) end if tmp_elem(:,:) = matmul((apply_elem(:,:)),tmp_elem(:,:)) if(present(mask))then - where(mask.and.(tmp_elem(:,:).lt.-tiny.or.tmp_elem(:,:).ge.1.D0-tiny)) + where(mask.and.(tmp_elem(:,:).lt.-tiny.or.tmp_elem(:,:).ge.1._real32-tiny)) tmp_elem(:,:) = tmp_elem(:,:) - floor(tmp_elem(:,:)+tiny) end where end if diff --git a/src/lib/mod_misc_maths.f90 b/src/fortran/lib/mod_misc_maths.f90 similarity index 60% rename from src/lib/mod_misc_maths.f90 rename to src/fortran/lib/mod_misc_maths.f90 index 869b0b0..c968032 100644 --- a/src/lib/mod_misc_maths.f90 +++ b/src/fortran/lib/mod_misc_maths.f90 @@ -31,96 +31,75 @@ !!! slater_array (apply slater distribution to a set of points in array) !!!############################################################################# module misc_maths + use artemis__constants, only: real32 implicit none integer, parameter :: QuadInt_K = selected_int_kind (16) - interface gauss - procedure rgauss,dgauss - end interface gauss - interface range - procedure rrange,drange - end interface range - interface normalise - procedure rnormalise,dnormalise - end interface normalise - interface running_avg - procedure rrunning_avg,drunning_avg - end interface running_avg - interface gauss_array - procedure rgauss_array,dgauss_array - end interface gauss_array - interface cauchy_array - procedure rcauchy_array,dcauchy_array - end interface cauchy_array - interface slater_array - procedure rslater_array,dslater_array - end interface slater_array +contains -!!!updated 2020/02/03 +!############################################################################### + function times(input) + !! Multiply an array by a scalar value + implicit none + ! Arguments + real(real32), dimension(:),intent(in) :: input + !! Array to be multiplied -contains -!!!##################################################### -!!! times all elements -!!!##################################################### - function times(in_array) - implicit none + ! Local variables integer :: i - real :: times - real, dimension(:),intent(in) :: in_array + !! Loop index + real(real32) :: times + !! Result of multiplication - times=1.0 - do i=1,size(in_array) - times=times*in_array(i) + times = 1._real32 + do i = 1, size( input, dim = 1 ) + times=times*input(i) end do end function times -!!!#####################################################= +!############################################################################### -!!!##################################################### -!!! evaluates a gausssian at a point -!!!##################################################### - function rgauss(pos,centre,sigma,tol) result(gauss) - real :: gauss,x - real :: pos,centre,sigma - real :: udef_tol - real, optional :: tol - if(present(tol))then - udef_tol=tol - else - udef_tol=16.D0 - end if - x=(pos-centre)**2.E0/(2.E0*sigma) - if(abs(x).lt.udef_tol) then - gauss=exp(-(x)) - else - gauss=0.D0 - end if - end function rgauss -!!!----------------------------------------------------- -!!!----------------------------------------------------- - function dgauss(pos,centre,sigma,tol) result(gauss) - double precision :: gauss,x - double precision :: pos,centre,sigma - double precision :: udef_tol - double precision, optional :: tol - if(present(tol))then - udef_tol=tol - else - udef_tol=38.D0 - end if - x=(pos-centre)**2.D0/(2.D0*sigma) - if(abs(x).lt.udef_tol) then - gauss=exp(-(x)) +!############################################################################### + function gauss(pos,centre,sigma,tol) result(output) + !! Evaluate a Gaussian at a point + implicit none + + ! Arguments + real(real32) :: pos + !! Position to evaluate the Gaussian at + real(real32) :: centre + !! Centre of the Gaussian + real(real32) :: sigma + !! Width of the Gaussian + real(real32), intent(in), optional :: tol + !! Tolerance for the Gaussian + + real(real32) :: output + !! Output value of the Gaussian + + ! Local variables + real(real32) :: x + !! Squared distance from the centre + real(real32) :: tol_ + !! Tolerance for the Gaussian + + tol_ = 38._real32 + if(present(tol)) tol_ = tol + + x = ( pos - centre ) ** 2._real32 / ( 2._real32 * sigma ) + if( abs(x) .lt. tol_ ) then + output = exp( -x ) else - gauss=0.D0 + output = 0._real32 end if - end function dgauss -!!!##################################################### + + end function gauss +!############################################################################### !!!##################################################### @@ -142,7 +121,7 @@ end function fact !!!##################################################### !!! Sum of logs of range from 1 to n !!!##################################################### - double precision function lnsum(n) + real(real32) function lnsum(n) implicit none integer :: i,n lnsum=0 @@ -159,11 +138,11 @@ end function lnsum !!! safe cos !!!##################################################### pure elemental function safe_acos(inval) result(val) - double precision, intent(in) :: inval - double precision :: val + real(real32), intent(in) :: inval + real(real32) :: val - if(abs(inval).ge.1.D0)then - val=acos(sign(1.D0,inval)) + if(abs(inval).ge.1._real32)then + val=acos(sign(1._real32,inval)) else val=acos(inval) end if @@ -187,8 +166,8 @@ function overlap_indiv_points(f,g) result(overlap) implicit none integer :: n integer :: datsize_f, datsize_g - real, dimension(:) :: f, g - real, dimension(:), allocatable :: overlap, y + real(real32), dimension(:) :: f, g + real(real32), dimension(:), allocatable :: overlap, y datsize_f = size(f) datsize_g = size(g) @@ -215,9 +194,9 @@ function overlap(f,g) implicit none integer :: n integer :: datsize_f, datsize_g - real :: overlap - real, dimension(:) :: f, g - real, dimension(:), allocatable :: y + real(real32) :: overlap + real(real32), dimension(:) :: f, g + real(real32), dimension(:), allocatable :: y datsize_f = size(f) datsize_g = size(g) @@ -243,8 +222,8 @@ function convolve(f,g) !f is the signal array !g is the noise/impulse array - real, dimension(:), allocatable :: convolve, y - real, dimension(:) :: f, g + real(real32), dimension(:), allocatable :: convolve, y + real(real32), dimension(:) :: f, g integer :: datsize_f, datsize_g integer :: i,j,k @@ -290,8 +269,8 @@ function cross_correl(f,g) !f is the signal array !g is the noise/impulse array - real, dimension(:), allocatable :: cross_correl, y - real, dimension(:) :: f, g + real(real32), dimension(:), allocatable :: cross_correl, y + real(real32), dimension(:) :: f, g integer :: datsize_f, datsize_g integer :: m,n @@ -326,52 +305,12 @@ end function cross_correl !!!##################################################### !!! smooths a function using a running average !!!##################################################### - function rrunning_avg(in_array,window,lperiodic) result(out_array) + function running_avg(in_array,window,lperiodic) result(out_array) implicit none integer :: i,lw,up,nstep integer, intent(in) :: window - real, dimension(:), intent(in) :: in_array - real, dimension(size(in_array,dim=1)) :: out_array - logical, optional :: lperiodic - - nstep=size(in_array) - if(mod(real(window),2.0).eq.0.0)then - lw = nint(real(window)/2.0)-1 - up = nint(real(window)/2.0) - else - lw = (floor(real(window)/2.0)) - up = (floor(real(window)/2.0)) - end if - - out_array=0.0 - if(present(lperiodic))then - if(lperiodic)then - do i=1,lw - out_array(i)=sum(in_array(nstep-lw+i:nstep))+& - sum(in_array(1:i+up)) - end do - do i=lw+1,nstep-up - out_array(i)=sum(in_array(i-lw:i+up)) - end do - do i=nstep-up+1,nstep - out_array(i)=sum(in_array(i-lw:nstep))+& - sum(in_array(1:up-(nstep-i))) - end do - out_array=out_array/window - return - end if - end if - out_array=in_array - - end function rrunning_avg -!!!----------------------------------------------------- -!!!----------------------------------------------------- - function drunning_avg(in_array,window,lperiodic) result(out_array) - implicit none - integer :: i,lw,up,nstep - integer, intent(in) :: window - double precision, dimension(:), intent(in) :: in_array - double precision, dimension(size(in_array,dim=1)) :: out_array + real(real32), dimension(:), intent(in) :: in_array + real(real32), dimension(size(in_array,dim=1)) :: out_array logical, optional :: lperiodic nstep=size(in_array) @@ -403,7 +342,7 @@ function drunning_avg(in_array,window,lperiodic) result(out_array) end if out_array=in_array - end function drunning_avg + end function running_avg !!!##################################################### @@ -412,8 +351,8 @@ end function drunning_avg !!!##################################################### function mean(in_array) implicit none - real :: mean - real, dimension(:), intent(in) :: in_array + real(real32) :: mean + real(real32), dimension(:), intent(in) :: in_array mean=sum(in_array)/size(in_array) @@ -427,9 +366,9 @@ end function mean function median(in_array) implicit none integer :: i,loc - real :: median,oddeven,rtmp1 - real, allocatable, dimension(:) :: cp_array - real, dimension(:), intent(in) :: in_array + real(real32) :: median,oddeven,rtmp1 + real(real32), allocatable, dimension(:) :: cp_array + real(real32), dimension(:), intent(in) :: in_array allocate(cp_array(size(in_array))) cp_array=in_array @@ -458,13 +397,13 @@ end function median function mode(in_array) implicit none integer :: i,itmp1,maxcount - real :: mode - real, dimension(:), intent(in) :: in_array + real(real32) :: mode + real(real32), dimension(:), intent(in) :: in_array maxcount=0 do i=1,size(in_array) itmp1=count(in_array.eq.in_array(i)) - itmp1=count(abs(in_array-in_array(i)).lt.1.D-8) + itmp1=count(abs(in_array-in_array(i)).lt.1.E-8_real32) if(itmp1.gt.maxcount)then maxcount=itmp1 mode=in_array(i) @@ -478,60 +417,34 @@ end function mode !!!##################################################### !!! returns the range of a set of points !!!##################################################### - function rrange(in_array) result(range) + function range(in_array) result(output) implicit none - real :: range - real, dimension(:), intent(in) :: in_array + real(real32) :: output + real(real32), dimension(:), intent(in) :: in_array - range=maxval(in_array)-minval(in_array) + output=maxval(in_array)-minval(in_array) - end function rrange -!!!----------------------------------------------------- -!!!----------------------------------------------------- - function drange(in_array) result(range) - implicit none - double precision :: range - double precision, dimension(:), intent(in) :: in_array - - range=maxval(in_array)-minval(in_array) - - end function drange + end function range !!!##################################################### !!!##################################################### !!! returns an array normalised to one !!!##################################################### - function rnormalise(in_array) result(normal) + function normalise(in_array) result(output) implicit none - real :: sumval - real, dimension(:), intent(in) :: in_array - real, dimension(size(in_array)) :: normal - - sumval=sum(in_array) - if(sumval.lt.1.D-8)then - normal=in_array - else - normal=in_array/sum(in_array) - end if - - end function rnormalise -!!!----------------------------------------------------- -!!!----------------------------------------------------- - function dnormalise(in_array) result(normal) - implicit none - double precision :: sumval - double precision, dimension(:), intent(in) :: in_array - double precision, dimension(size(in_array)) :: normal + real(real32) :: sumval + real(real32), dimension(:), intent(in) :: in_array + real(real32), dimension(size(in_array)) :: output sumval=sum(in_array) - if(sumval.lt.1.D-8)then - normal=in_array + if(sumval.lt.1.E-8_real32)then + output=in_array else - normal=in_array/sum(in_array) + output=in_array/sum(in_array) end if - end function dnormalise + end function normalise !!!##################################################### @@ -544,8 +457,8 @@ end function dnormalise function get_turn_points(invec,lperiodic,window) result(resvec) implicit none integer :: i,j,nturn,itmp1,itmp2 - double precision :: l_grad,r_grad - double precision, dimension(:), intent(in) :: invec + real(real32) :: l_grad,r_grad + real(real32), dimension(:), intent(in) :: invec integer, allocatable, dimension(:) :: tvec1,resvec integer, optional :: window logical, optional :: lperiodic @@ -554,13 +467,13 @@ function get_turn_points(invec,lperiodic,window) result(resvec) nturn=0 if(allocated(resvec)) deallocate(resvec) allocate(tvec1(size(invec))) - l_grad=0.D0 + l_grad=0._real32 r_grad=invec(2)-invec(1) if(present(lperiodic))then if(lperiodic)then l_grad=invec(1)-invec(size(invec)) - if(sign(1.D0,l_grad).ne.sign(1.D0,r_grad).or.& - (r_grad.eq.0.D0.and.l_grad.ne.r_grad))then + if(sign(1._real32,l_grad).ne.sign(1._real32,r_grad).or.& + (r_grad.eq.0._real32.and.l_grad.ne.r_grad))then nturn=nturn+1 tvec1(nturn)=1 end if @@ -571,8 +484,8 @@ function get_turn_points(invec,lperiodic,window) result(resvec) do i=2,size(invec)-1 l_grad=r_grad r_grad=invec(i+1)-invec(i) - if(sign(1.D0,l_grad).ne.sign(1.D0,r_grad).or.& - (r_grad.eq.0.D0.and.abs(l_grad-r_grad).gt.1.D-5))then + if(sign(1._real32,l_grad).ne.sign(1._real32,r_grad).or.& + (r_grad.eq.0._real32.and.abs(l_grad-r_grad).gt.1.E-5_real32))then nturn=nturn+1 tvec1(nturn)=i end if @@ -582,8 +495,8 @@ function get_turn_points(invec,lperiodic,window) result(resvec) if(present(lperiodic))then if(lperiodic)then r_grad=invec(1)-invec(size(invec)) - if(sign(1.D0,l_grad).ne.sign(1.D0,r_grad).or.& - (r_grad.eq.0.D0.and.l_grad.ne.r_grad))then + if(sign(1._real32,l_grad).ne.sign(1._real32,r_grad).or.& + (r_grad.eq.0._real32.and.l_grad.ne.r_grad))then nturn=nturn+1 tvec1(nturn)=size(invec) end if @@ -626,11 +539,11 @@ end function get_turn_points function get_nth_plane(invec,nth,window,is_periodic) result(startend) implicit none integer :: i,nstep,nplane,udef_window - double precision :: tol + real(real32) :: tol logical :: is_in_plane integer, dimension(2) :: startend integer, allocatable, dimension(:,:) :: plane_loc - double precision, dimension(:), intent(in) :: invec + real(real32), dimension(:), intent(in) :: invec integer, intent(in) :: nth integer, optional, intent(in) :: window logical, optional, intent(in) :: is_periodic @@ -639,7 +552,7 @@ function get_nth_plane(invec,nth,window,is_periodic) result(startend) !!!----------------------------------------------------------------------------- !!! Defines tolerance of plane height variation and initialises variables !!!----------------------------------------------------------------------------- - tol = 0.01D0*(maxval(invec)-minval(invec)) + tol = 0.01_real32*(maxval(invec)-minval(invec)) if(present(window))then udef_window=window else @@ -744,16 +657,16 @@ end function get_nth_plane !!!##################################################### !!! Ned's custom table function !!!##################################################### -!!! BREAKS ON a = 1.D0 +!!! BREAKS ON a = 1._real32 !!! ABOVE THIS, res WILL ALWAYS EQUAL 1 !!! a should be between -1 and 1? function table_func(x,a) result(res) implicit none - double precision, intent(in) :: x,a - double precision :: res + real(real32), intent(in) :: x,a + real(real32) :: res - res=( ( cos(x) + a ) + abs( cos(x) - a ) - 2.D0 )/& - ( 2.D0*a - 2.D0 ) + res=( ( cos(x) + a ) + abs( cos(x) - a ) - 2._real32 )/& + ( 2._real32*a - 2._real32 ) end function table_func @@ -763,256 +676,134 @@ end function table_func !!!##################################################### !!! apply gaussians to a set of points in an array !!!##################################################### - function rgauss_array(distance,in_array,sigma,tol,norm,mask) & + function gauss_array(distance,in_array,sigma,tol,norm,mask) & result(gauss_func) implicit none integer :: i,n,init_step - real :: x,sigma,udef_tol,mult - real, optional :: tol + real(real32) :: x,sigma,tol_,mult + real(real32), optional :: tol logical, optional :: norm - real, dimension(:), intent(in) :: in_array,distance - real, dimension(size(distance)) :: gauss_func - real :: pi = 4.0*atan(1.0) + real(real32), dimension(:), intent(in) :: in_array,distance + real(real32), dimension(size(distance)) :: gauss_func + real(real32) :: pi = 4._real32*atan(1._real32) logical, dimension(size(distance)), optional, intent(in) :: mask - udef_tol=16.0 - if(present(tol)) udef_tol=tol - mult=(1.0/(sqrt(pi*2.0)*sigma)) + tol_ = 38._real32 + if(present(tol)) tol_ = tol + mult=(1._real32/(sqrt(pi*2._real32)*sigma)) if(present(norm))then - if(.not.norm) mult=1.0 + if(.not.norm) mult=1._real32 end if - gauss_func=0.0 + gauss_func=0._real32 do n=1,size(in_array) if(present(mask))then if(.not.mask(n)) cycle end if init_step=minloc(abs( distance(:) - in_array(n) ),dim=1) forward: do i=init_step,size(distance),1 - x=0.5*(( distance(i) - in_array(n) )/sigma)**2.0 - if(x.gt.udef_tol) exit forward + x=0.5_real32*(( distance(i) - in_array(n) )/sigma)**2._real32 + if(x.gt.tol_) exit forward gauss_func(i) = gauss_func(i) + exp(-x) * mult end do forward backward: do i=init_step-1,1,-1 - x=0.5*(( distance(i) - in_array(n) )/sigma)**2.0 - if(x.gt.udef_tol) exit backward + x=0.5_real32*(( distance(i) - in_array(n) )/sigma)**2._real32 + if(x.gt.tol_) exit backward gauss_func(i) = gauss_func(i) + exp(-x) * mult end do backward end do - end function rgauss_array -!!!----------------------------------------------------- -!!!----------------------------------------------------- - function dgauss_array(distance,in_array,sigma,tol,norm,mask) & - result(gauss_func) - implicit none - integer :: i,n,init_step - double precision :: x,sigma,udef_tol,mult - double precision, optional :: tol - logical, optional :: norm - double precision, dimension(:), intent(in) :: in_array,distance - double precision, dimension(size(distance)) :: gauss_func - double precision :: pi = 4.D0*atan(1.D0) - - logical, dimension(size(distance)), optional, intent(in) :: mask - - - udef_tol=38.D0 - if(present(tol)) udef_tol=tol - mult=(1.D0/(sqrt(pi*2.D0)*sigma)) - if(present(norm))then - if(.not.norm) mult=1.D0 - end if - - gauss_func=0.D0 - do n=1,size(in_array) - if(present(mask))then - if(.not.mask(n)) cycle - end if - init_step=minloc(abs( distance(:) - in_array(n) ),dim=1) - forward: do i=init_step,size(distance),1 - x=0.5D0*(( distance(i) - in_array(n) )/sigma)**2.D0 - if(x.gt.udef_tol) exit forward - gauss_func(i) = gauss_func(i) + exp(-x) * mult - end do forward - - backward: do i=init_step-1,1,-1 - x=0.5D0*(( distance(i) - in_array(n) )/sigma)**2.D0 - if(x.gt.udef_tol) exit backward - gauss_func(i) = gauss_func(i) + exp(-x) * mult - end do backward - end do - - - - end function dgauss_array + end function gauss_array !!!##################################################### !!!##################################################### !!! apply cauchy distribution to a set of points in an array !!!##################################################### - function rcauchy_array(distance,in_array,gamma,tol,norm) result(c_func) - implicit none - integer :: i,n,init_step - real :: x,gamma,udef_tol,mult - real, optional :: tol - logical, optional :: norm - real, dimension(:), intent(in) :: in_array,distance - real, dimension(size(distance)) :: c_func - real :: pi = 4.0*atan(1.0) - - - udef_tol=1.E16 - if(present(tol)) udef_tol=tol - mult=(1.0/(pi*gamma)) - if(present(norm))then - if(.not.norm) mult=1.0 - end if - - c_func=0.0 - do n=1,size(in_array) - init_step=minloc(abs( distance(:) - in_array(n) ),dim=1) - forward: do i=init_step,size(distance),1 - x = 1.0 + (( distance(i) - in_array(n) )/gamma)**2.0 - if(x.gt.udef_tol) exit forward - c_func(i) = c_func(i) + 1.0/(x) * mult - end do forward - - backward: do i=init_step-1,1,-1 - x = 1.0 + (( distance(i) - in_array(n) )/gamma)**2.0 - if(x.gt.udef_tol) exit backward - c_func(i) = c_func(i) + 1.0/x * mult - end do backward - end do - - - - end function rcauchy_array -!!!----------------------------------------------------- -!!!----------------------------------------------------- - function dcauchy_array(distance,in_array,gamma,tol,norm) result(c_func) + function cauchy_array(distance,in_array,gamma,tol,norm) result(c_func) implicit none integer :: i,n,init_step - double precision :: x,gamma,udef_tol,mult - double precision, optional :: tol + real(real32) :: x,gamma,tol_,mult + real(real32), optional :: tol logical, optional :: norm - double precision, dimension(:), intent(in) :: in_array,distance - double precision, dimension(size(distance)) :: c_func - double precision :: pi = 4.D0*atan(1.D0) + real(real32), dimension(:), intent(in) :: in_array,distance + real(real32), dimension(size(distance)) :: c_func + real(real32) :: pi = 4._real32*atan(1._real32) - udef_tol=1.D16 - if(present(tol)) udef_tol=tol - mult=(1.D0/(pi*gamma)) + tol_ = 1.E16_real32 + if(present(tol)) tol_=tol + mult=(1._real32/(pi*gamma)) if(present(norm))then - if(.not.norm) mult=1.D0 + if(.not.norm) mult=1._real32 end if - c_func=0.D0 + c_func=0._real32 do n=1,size(in_array) init_step=minloc(abs( distance(:) - in_array(n) ),dim=1) forward: do i=init_step,size(distance),1 - x = 1.D0 + (( distance(i) - in_array(n) )/gamma)**2.D0 - if(x.gt.udef_tol) exit forward - c_func(i) = c_func(i) + 1.D0/(x) * mult + x = 1._real32 + (( distance(i) - in_array(n) )/gamma)**2._real32 + if(x.gt.tol_) exit forward + c_func(i) = c_func(i) + 1._real32/(x) * mult end do forward backward: do i=init_step-1,1,-1 - x = 1.D0 + (( distance(i) - in_array(n) )/gamma)**2.D0 - if(x.gt.udef_tol) exit backward - c_func(i) = c_func(i) + 1.D0/x * mult + x = 1._real32 + (( distance(i) - in_array(n) )/gamma)**2._real32 + if(x.gt.tol_) exit backward + c_func(i) = c_func(i) + 1._real32/x * mult end do backward end do - end function dcauchy_array + end function cauchy_array !!!##################################################### !!!##################################################### !!! apply slater distribution to a set of points in an array !!!##################################################### - function rslater_array(distance,in_array,zeta,tol,norm) result(s_func) - implicit none - integer :: i,n,init_step - real :: x,zeta,udef_tol,mult - real, optional :: tol - logical, optional :: norm - real, dimension(:), intent(in) :: in_array,distance - real, dimension(size(distance)) :: s_func - real :: pi = 4.0*atan(1.0) - - - udef_tol=38.0 - if(present(tol)) udef_tol=tol - mult=((zeta**3.0)/pi)**(0.5) - if(present(norm))then - if(.not.norm) mult=1.0 - end if - - s_func=0.0 - do n=1,size(in_array) - init_step=minloc(abs( distance(:) - in_array(n) ),dim=1) - forward: do i=init_step,size(distance),1 - x = zeta*abs( distance(i) - in_array(n) ) - if(x.gt.udef_tol) exit forward - s_func(i) = s_func(i) + exp(-x) * mult - end do forward - - backward: do i=init_step-1,1,-1 - x = zeta*abs( distance(i) - in_array(n) ) - if(x.gt.udef_tol) exit backward - s_func(i) = s_func(i) + exp(-x) * mult - end do backward - end do - - - end function rslater_array -!!!----------------------------------------------------- -!!!----------------------------------------------------- - function dslater_array(distance,in_array,zeta,tol,norm) result(s_func) + function slater_array(distance,in_array,zeta,tol,norm) result(s_func) implicit none integer :: i,n,init_step - double precision :: x,zeta,udef_tol,mult - double precision, optional :: tol + real(real32) :: x,zeta,tol_,mult + real(real32), optional :: tol logical, optional :: norm - double precision, dimension(:), intent(in) :: in_array,distance - double precision, dimension(size(distance)) :: s_func - double precision :: pi = 4.D0*atan(1.D0) + real(real32), dimension(:), intent(in) :: in_array,distance + real(real32), dimension(size(distance)) :: s_func + real(real32) :: pi = 4._real32*atan(1._real32) - udef_tol=38.D0 - if(present(tol)) udef_tol=tol - mult=((zeta**3.D0)/pi)**(0.5D0) + tol_ = 38._real32 + if(present(tol)) tol_=tol + mult=((zeta**3._real32)/pi)**(0.5_real32) if(present(norm))then - if(.not.norm) mult=1.D0 + if(.not.norm) mult=1._real32 end if - s_func=0.D0 + s_func=0._real32 do n=1,size(in_array) init_step=minloc(abs( distance(:) - in_array(n) ),dim=1) forward: do i=init_step,size(distance),1 x = zeta*abs( distance(i) - in_array(n) ) - if(x.gt.udef_tol) exit forward + if(x.gt.tol_) exit forward s_func(i) = s_func(i) + exp(-x) * mult end do forward backward: do i=init_step-1,1,-1 x = zeta*abs( distance(i) - in_array(n) ) - if(x.gt.udef_tol) exit backward + if(x.gt.tol_) exit backward s_func(i) = s_func(i) + exp(-x) * mult end do backward end do - end function dslater_array + end function slater_array !!!##################################################### end module misc_maths diff --git a/src/fortran/lib/mod_misc_types.f90 b/src/fortran/lib/mod_misc_types.f90 new file mode 100644 index 0000000..c298709 --- /dev/null +++ b/src/fortran/lib/mod_misc_types.f90 @@ -0,0 +1,323 @@ +module artemis__misc_types + !! Module containing custom derived types for ARTEMIS + use artemis__constants, only: real32, pi + use artemis__misc, only: to_lower + use artemis__geom_rw, only: basis_type, geom_write + use artemis__geom_utils, only: MATNORM + implicit none + + + private + + public :: struc_data_type + public :: latmatch_type + public :: tol_type + public :: abstract_artemis_generator_type + + + type struc_data_type + integer :: match_idx = 0 + integer :: match_and_term_idx = 0 + integer :: shift_idx = 0 + integer :: swap_idx = 0 + logical :: from_pricel_lw = .false. + logical :: from_pricel_up = .false. + integer, dimension(2) :: term_lw_idx = 0 + integer, dimension(2) :: term_up_idx = 0 + real(real32), dimension(4) :: term_lw_bounds = 0._real32 + real(real32), dimension(4) :: term_up_bounds = 0._real32 + integer, dimension(2) :: term_lw_natom = 0 + integer, dimension(2) :: term_up_natom = 0 + integer, dimension(3,3) :: transform_lw = 0 + integer, dimension(3,3) :: transform_up = 0 + real(real32) :: approx_thickness_lw = 0._real32 + real(real32) :: approx_thickness_up = 0._real32 + real(real32), dimension(3) :: mismatch + real(real32), dimension(3) :: shift = 0._real32 + ! real(real32), dimension(:,:) :: swaps !!! UNSURE HOW TO DO THIS + real(real32) :: swap_density = 0._real32 + real(real32), dimension(2) :: approx_eff_swap_conc = 0._real32 + + end type struc_data_type + + interface struc_data_type + module function init_struc_data_type( & + match_idx, & + match_and_term_idx, & + from_pricel_lw, from_pricel_up, & + term_lw_idx, term_up_idx, & + term_lw_bounds, term_up_bounds, & + term_lw_natom, term_up_natom, & + transform_lw, transform_up, & + approx_thickness_lw, approx_thickness_up, & + mismatch, & + shift_idx, shift, & + swap_idx, swap_density, approx_eff_swap_conc & + ) result(output) + integer, intent(in) :: match_idx + integer, intent(in) :: match_and_term_idx + logical, intent(in) :: from_pricel_lw, from_pricel_up + integer, dimension(2), intent(in) :: term_lw_idx, term_up_idx + real(real32), dimension(4), intent(in) :: term_lw_bounds, term_up_bounds + integer, dimension(2), intent(in) :: term_lw_natom, term_up_natom + integer, dimension(3,3), intent(in) :: transform_lw, transform_up + real(real32), intent(in) :: approx_thickness_lw, approx_thickness_up + real(real32), dimension(3), intent(in) :: mismatch + integer, intent(in), optional :: shift_idx + real(real32), dimension(3), intent(in), optional :: shift + integer, intent(in), optional :: swap_idx + real(real32), intent(in), optional :: swap_density + real(real32), dimension(2), intent(in), optional :: approx_eff_swap_conc + type(struc_data_type) :: output + end function init_struc_data_type + end interface struc_data_type + + type latmatch_type + integer :: nfit + integer :: max_num_matches = 5 + logical :: reduce = .false. + logical :: reduced = .false. + character(1) :: abc(3)= [ 'a', 'b', 'c' ] + + integer, dimension(2) :: axes + integer, allocatable, dimension(:,:,:) :: tf1,tf2 + real(real32), allocatable, dimension(:,:) :: tol + real(real32), dimension(3,3) :: lat1,lat2 + contains + procedure, pass(this) :: init => latmatch_init + procedure, pass(this) :: constrain_axes + end type latmatch_type + + type tol_type + integer :: maxfit = 100 + integer :: maxsize = 10 + real(real32) :: maxlen = 20._real32 + real(real32) :: maxarea = 400._real32 + real(real32) :: vec = 5._real32 / 100._real32 + real(real32) :: ang = 1._real32 * pi / 180._real32 + real(real32) :: area = 10._real32 / 100._real32 + real(real32) :: ang_weight = 10._real32 + real(real32) :: area_weight = 100._real32 + end type tol_type + + type :: abstract_artemis_generator_type + integer :: num_structures = 0 + integer :: max_num_structures = 100 + + integer :: axis = 3 + !! Axis along which to align the slab/interface normal vector + + real(real32) :: vacuum_gap = 14._real32 + !! Vacuum thickness in Å + + type(basis_type), dimension(:), allocatable :: structures + contains + procedure, pass(this) :: write_structures + procedure, pass(this) :: get_structures + procedure, pass(this) :: set_structures + end type abstract_artemis_generator_type + + +contains + +!############################################################################### + module function init_struc_data_type( & + match_idx, & + match_and_term_idx, & + from_pricel_lw, from_pricel_up, & + term_lw_idx, term_up_idx, & + term_lw_bounds, term_up_bounds, & + term_lw_natom, term_up_natom, & + transform_lw, transform_up, & + approx_thickness_lw, approx_thickness_up, & + mismatch, & + shift_idx, shift, & + swap_idx, swap_density, approx_eff_swap_conc & + ) result(output) + implicit none + integer, intent(in) :: match_idx + integer, intent(in) :: match_and_term_idx + logical, intent(in) :: from_pricel_lw, from_pricel_up + integer, dimension(2), intent(in) :: term_lw_idx, term_up_idx + real(real32), dimension(4), intent(in) :: term_lw_bounds, term_up_bounds + integer, dimension(2), intent(in) :: term_lw_natom, term_up_natom + integer, dimension(3,3), intent(in) :: transform_lw, transform_up + real(real32), intent(in) :: approx_thickness_lw, approx_thickness_up + real(real32), dimension(3), intent(in) :: mismatch + integer, intent(in), optional :: shift_idx + real(real32), dimension(3), intent(in), optional :: shift + integer, intent(in), optional :: swap_idx + real(real32), intent(in), optional :: swap_density + real(real32), dimension(2), intent(in), optional :: approx_eff_swap_conc + + type(struc_data_type) :: output + + output%match_idx = match_idx + output%match_and_term_idx = match_and_term_idx + output%from_pricel_lw = from_pricel_lw + output%from_pricel_up = from_pricel_up + output%term_lw_idx = term_lw_idx + output%term_up_idx = term_up_idx + output%term_lw_bounds = term_lw_bounds + output%term_up_bounds = term_up_bounds + output%term_lw_natom = term_lw_natom + output%term_up_natom = term_up_natom + output%transform_lw = transform_lw + output%transform_up = transform_up + output%approx_thickness_lw = approx_thickness_lw + output%approx_thickness_up = approx_thickness_up + output%mismatch = mismatch + + if(present(shift)) output%shift = shift + if(present(shift_idx)) output%shift_idx = shift_idx + + if(present(swap_idx)) output%swap_idx = swap_idx + if(present(swap_density)) output%swap_density = swap_density + if(present(approx_eff_swap_conc)) output%approx_eff_swap_conc = approx_eff_swap_conc + + end function init_struc_data_type + +!############################################################################### + + +!############################################################################### + subroutine latmatch_init( & + this, tol, lattice_lw, lattice_up, max_num_matches, reduce_matches & + ) + implicit none + class(latmatch_type), intent(inout) :: this + type(tol_type), intent(in) :: tol + integer, intent(in) :: max_num_matches + real(real32), dimension(3,3), intent(in) :: lattice_lw,lattice_up + logical, intent(in) :: reduce_matches + + this%max_num_matches = max_num_matches + allocate(this%tf1(this%max_num_matches,3,3)) + allocate(this%tf2(this%max_num_matches,3,3)) + allocate(this%tol(this%max_num_matches,3)) + + this%tol(:,:) = huge(0._real32) + this%lat1 = MATNORM(lattice_lw) + this%lat2 = MATNORM(lattice_up) + + this%reduce = reduce_matches + + end subroutine latmatch_init +!############################################################################### + + +!############################################################################### + subroutine constrain_axes(this, miller_lw, miller_up, verbose) + implicit none + class(latmatch_type), intent(inout) :: this + integer, dimension(3), intent(in) :: miller_lw, miller_up + integer, intent(in) :: verbose + + + if(all(miller_lw.eq.0))then + this%axes(1) = 3 + if(verbose.gt.0) write(*,*) & + "Finding matches for all possible lower planes." + else + this%axes(1) = 2 + if(verbose.gt.0) write(*,*) "Finding matches for the lower ab plane." + end if + + if(all(miller_up.eq.0))then + this%axes(2) = 3 + if(verbose.gt.0) write(*,*) & + "Finding matches for all possible upper planes." + else + this%axes(2) = 2 + if(verbose.gt.0) write(*,*) "Finding matches for the upper ab plane." + end if + + end subroutine constrain_axes +!############################################################################### + + +!############################################################################### + subroutine write_structures( & + this, directory, prefix & + ) + !! Write the generated terminations to file + implicit none + + ! Arguments + class(abstract_artemis_generator_type), intent(in) :: this + !! Instance of artemis generator type + character(len=*), intent(in) :: directory + !! Directory to write the files to + character(len=*), intent(in), optional :: prefix + !! Prefix for the output files + + ! Local variables + integer :: i + !! Loop variable + integer :: unit + !! File unit number + character(len=256) :: filename, filename_template + !! File name for the output files + character(len=:), allocatable :: prefix_ + !! Prefix for the output files + + + + if(trim(directory).ne."") then + call system('mkdir -p '//trim(adjustl(directory))) + end if + + filename_template = "POSCAR" + if(present(prefix)) then + prefix_ = trim(to_lower(prefix)) + filename_template = trim(filename_template) // "_" // trim(prefix_) + end if + if(allocated(this%structures))then + do i = 1, size(this%structures) + write(filename,'(A,I0)') trim(filename_template), i + if(trim(directory).ne."") then + filename = trim(directory) // "/" // trim(filename) + end if + open(newunit=unit,file=filename) + call geom_write(unit, this%structures(i)) + close(unit) + end do + else + write(0,'(1X,"No structures to write.")') + end if + + end subroutine write_structures +!############################################################################### + + +!############################################################################### + function get_structures(this) result(structures) + !! Get the generated structures. + implicit none + ! Arguments + class(abstract_artemis_generator_type), intent(in) :: this + !! Instance of the artemis generator. + type(basis_type), dimension(:), allocatable :: structures + !! Generated structures. + + structures = this%structures + end function get_structures +!############################################################################### + + +!############################################################################### + subroutine set_structures(this, structures) + !! Set the generated structures. + implicit none + ! Arguments + class(abstract_artemis_generator_type), intent(inout) :: this + !! Instance of the artemis generator. + type(basis_type), dimension(:), allocatable :: structures + !! Generated structures. + + this%structures = structures + this%num_structures = size(structures) + end subroutine set_structures +!############################################################################### + +end module artemis__misc_types diff --git a/src/mod_plane_matching.f90 b/src/fortran/lib/mod_plane_matching.f90 similarity index 77% rename from src/mod_plane_matching.f90 rename to src/fortran/lib/mod_plane_matching.f90 index 3af7f2a..ccf5c21 100644 --- a/src/mod_plane_matching.f90 +++ b/src/fortran/lib/mod_plane_matching.f90 @@ -4,21 +4,13 @@ !!! Think Hepplestone, think HRG. !!!############################################################################# module plane_matching - use constants + use artemis__constants, only: real32, INF, pi use misc_linalg, only: cross,modu,get_angle,get_area,find_tf,& - reduce_vec_gcd,gcd + reduce_vec_gcd,gcd, inverse_2x2, find_tf_2x2, uvec + use artemis__misc_types, only: tol_type implicit none !! importance of vector, angle, and area - double precision, dimension(3) :: vaa_weighting=(/1.D0,5.D0,2.5D0/) - - type :: pm_tol_type - integer :: maxsize,maxfit,nstore - double precision :: maxlen=20.D0 - double precision :: maxarea=400.D0 - double precision :: vec,ang,area - double precision :: ang_weight = 10.D0 - double precision :: area_weight = 100.D0 - end type pm_tol_type + real(real32), dimension(3) :: vaa_weighting=(/1._real32,5._real32,2.5_real32/) !!!updated 2021/11/11 @@ -31,10 +23,10 @@ module plane_matching !!!############################################################################# subroutine datasort(list_in,tol_in) implicit none - double precision, dimension(:,:,:) :: list_in - double precision, allocatable, dimension(:,:,:) :: list_out - double precision, dimension(:) :: tol_in - double precision, allocatable, dimension(:) :: tol_out + real(real32), dimension(:,:,:) :: list_in + real(real32), allocatable, dimension(:,:,:) :: list_out + real(real32), dimension(:) :: tol_in + real(real32), allocatable, dimension(:) :: tol_out integer :: a,dummylocation,len len=size(list_in(:,1,1)) @@ -62,12 +54,12 @@ subroutine datasortmain(list_in,mat1_in,mat2_in,trans1_in,trans2_in) implicit none integer :: len integer :: a,dummylocation - double precision, dimension(:,:,:) :: mat1_in,mat2_in - double precision, allocatable, dimension(:,:,:) :: mat1_out,mat2_out - double precision, dimension(:,:,:) :: trans1_in,trans2_in - double precision, allocatable, dimension(:,:,:) :: trans1_out,trans2_out - double precision, dimension(:) :: list_in - double precision, allocatable, dimension(:) :: list_out + real(real32), dimension(:,:,:) :: mat1_in,mat2_in + real(real32), allocatable, dimension(:,:,:) :: mat1_out,mat2_out + real(real32), dimension(:,:,:) :: trans1_in,trans2_in + real(real32), allocatable, dimension(:,:,:) :: trans1_out,trans2_out + real(real32), dimension(:) :: list_in + real(real32), allocatable, dimension(:) :: list_out len = size(list_in) @@ -103,11 +95,11 @@ end subroutine datasortmain subroutine datasort_tols(list_in,tol_in) implicit none integer :: i,j,len,ntol_features - double precision, allocatable,dimension(:) :: vtmp1 - double precision, dimension(:,:,:) :: list_in - double precision, allocatable, dimension(:,:,:) :: list_out - double precision, dimension(:,:) :: tol_in - double precision, allocatable, dimension(:,:) :: tol_out,tmp_store + real(real32), allocatable,dimension(:) :: vtmp1 + real(real32), dimension(:,:,:) :: list_in + real(real32), allocatable, dimension(:,:,:) :: list_out + real(real32), dimension(:,:) :: tol_in + real(real32), allocatable, dimension(:,:) :: tol_out,tmp_store ntol_features = size(tol_in(1,:)) len = size(list_in(:,1,1)) @@ -147,12 +139,12 @@ end subroutine datasort_tols subroutine datasortmain_tols(tol,mat1,mat2,trans1,trans2) implicit none integer :: i,j,len - double precision, dimension(3) :: vtmp1 - double precision, dimension(2,2) :: dmat1 - double precision, dimension(3,3) :: dmat2 - double precision, dimension(:,:,:) :: mat1,mat2 - double precision, dimension(:,:,:) :: trans1,trans2 - double precision, dimension(:,:) :: tol + real(real32), dimension(3) :: vtmp1 + real(real32), dimension(2,2) :: dmat1 + real(real32), dimension(3,3) :: dmat2 + real(real32), dimension(:,:,:) :: mat1,mat2 + real(real32), dimension(:,:,:) :: trans1,trans2 + real(real32), dimension(:,:) :: tol len=size(tol,dim=1) @@ -198,11 +190,11 @@ function is_duplicate(list1,list2,lat1,lat2,sym1,sym2) result(outval) implicit none integer :: i,len logical :: outval - double precision, dimension(:,:,:) :: list1,list2 ! The lists of already saved matrices - double precision, dimension(:,:) :: lat1,lat2 ! The pair of matrices we want to check - double precision, allocatable, dimension(:,:) :: dummy1,dummy2 - double precision, allocatable, dimension(:,:) :: tmplat1,tmplat2 - double precision, dimension(:,:,:), optional :: sym1,sym2 + real(real32), dimension(:,:,:) :: list1,list2 ! The lists of already saved matrices + real(real32), dimension(:,:) :: lat1,lat2 ! The pair of matrices we want to check + real(real32), allocatable, dimension(:,:) :: dummy1,dummy2 + real(real32), allocatable, dimension(:,:) :: tmplat1,tmplat2 + real(real32), dimension(:,:,:), optional :: sym1,sym2 len = size(list1(:,1,1)) @@ -212,14 +204,14 @@ function is_duplicate(list1,list2,lat1,lat2,sym1,sym2) result(outval) allocate( tmplat1( size( lat1(:,1)), size(lat1(1,:)) ) ) allocate( tmplat2( size( lat2(:,1)), size(lat2(1,:)) ) ) - dummy1 = dble(find_tf(lat1,lat2)) + dummy1 = real(find_tf(lat1,lat2),real32) LOOP: do i=1,len - if(all(abs(list1(i,:,:)).lt.1.D-5)) cycle LOOP + if(all(abs(list1(i,:,:)).lt.1.E-5_real32)) cycle LOOP tmplat1(:,:) = list1(i,:,:) tmplat2(:,:) = list2(i,:,:) - dummy2 = dble(find_tf(tmplat1,tmplat2)) + dummy2 = real(find_tf(tmplat1,tmplat2),real32) - if ( all(abs( dummy1(:,:)-dummy2(:,:) ) .lt. 1.D-5) ) then + if ( all(abs( dummy1(:,:)-dummy2(:,:) ) .lt. 1.E-5_real32) ) then outval = .true. ! write(0,*) "error" exit LOOP @@ -244,24 +236,24 @@ end function is_duplicate function is_unique(miller,sym) result(outval) implicit none integer :: i,j - double precision :: tol + real(real32) :: tol logical :: outval integer, dimension(3) :: miller - double precision, dimension(3) :: vec_in,vec_out,vec_tmp1,vec_tmp2 - double precision, dimension(:,:,:) :: sym + real(real32), dimension(3) :: vec_in,vec_out,vec_tmp1,vec_tmp2 + real(real32), dimension(:,:,:) :: sym -! if(dot_product(vec_out-vec_in,vec_out-vec_in).lt.1.D-5) -! if(all(abs(vec_out-vec_in).lt.1.D-5)) -! any(vec_in.eq.3.D0) -! all(vec_in.eq.3.D0) +! if(dot_product(vec_out-vec_in,vec_out-vec_in).lt.1.E-5_real32) +! if(all(abs(vec_out-vec_in).lt.1.E-5_real32)) +! any(vec_in.eq.3._real32) +! all(vec_in.eq.3._real32) outval = .true. - vec_in = dble(miller) + vec_in = real(miller,real32) vec_out = reduce_vec_gcd(vec_in) if (all(miller.eq.0)) then outval = .false. - else if (all(abs(vec_out-vec_in).lt.1.D-5)) then + else if (all(abs(vec_out-vec_in).lt.1.E-5_real32)) then outval = .true. else outval = .false. @@ -269,22 +261,22 @@ function is_unique(miller,sym) result(outval) if(.not.outval) return - tol=1.D-5 - if(all(vec_in.le.0.D0))then + tol = 1.E-5_real32 + if(all(vec_in.le.0._real32))then outval=.false. return end if signloop1: do j=1,3 if(abs(vec_in(j)).lt.tol) cycle signloop1 - vec_in=sign(1.D0,vec_in(j))*vec_in + vec_in=sign(1._real32,vec_in(j))*vec_in exit signloop1 end do signloop1 - symloop1: do i=1,size(sym(:,1,1),dim=1) - vec_out=matmul(vec_in,sym(i,:3,:3)) + symloop1: do i=1,size(sym,dim=3) + vec_out = matmul(vec_in,sym(:3,:3,i)) if(all(abs(vec_out-vec_in).lt.tol)) cycle symloop1 - vec_tmp1(:)=abs(vec_in(:))-abs(vec_out(:)) - vec_tmp2(:)=vec_in(:)-vec_out(:) + vec_tmp1(:) = abs(vec_in(:))-abs(vec_out(:)) + vec_tmp2(:) = vec_in(:)-vec_out(:) symloop2: do j=1,3 if(vec_tmp1(j).gt.tol.or.& (abs(vec_tmp1(j)).lt.tol.and.vec_tmp2(j).lt.-tol))then @@ -296,8 +288,6 @@ function is_unique(miller,sym) result(outval) end do symloop2 end do symloop1 - - end function is_unique !!!############################################################################# @@ -316,23 +306,23 @@ end function is_unique function is_unique_set(vec1,vec2,sym) result(outval) implicit none integer :: i,j - double precision :: tol + real(real32) :: tol integer, dimension(2) :: vec1,vec2 - double precision, dimension(3) :: vec_in,vec_out,vec_tmp1,vec_tmp2 - double precision, dimension(:,:,:) :: sym + real(real32), dimension(3) :: vec_in,vec_out,vec_tmp1,vec_tmp2 + real(real32), dimension(:,:,:) :: sym logical :: outval - tol=1.D-5 + tol = 1.E-5_real32 outval=.true. - vec_in=(/ dble(vec1(1)), dble(vec1(2)), 0.D0/) - !vec_in1=(/ dble(vec1(1)), dble(vec1(2)), 0.D0/) - !vec_in2=(/ dble(vec2(1)), dble(vec2(2)), 0.D0/) + vec_in=(/ real(vec1(1),real32), real(vec1(2),real32), 0._real32/) + !vec_in1=(/ real(vec1(1),real32), real(vec1(2),real32), 0._real32/) + !vec_in2=(/ real(vec2(1),real32), real(vec2(2),real32), 0._real32/) - symloop1: do i=1,size(sym(:,1,1),dim=1) + symloop1: do i=1,size(sym,dim=3) ! matmul inmat with sym ! then compare to mat_checklist - vec_out=matmul(vec_in,sym(i,:3,:3)) + vec_out=matmul(vec_in,sym(:3,:3,i)) if(all(abs(vec_out-vec_in).lt.tol)) cycle symloop1 vec_tmp1(:)=abs(vec_in(:))-abs(vec_out(:)) vec_tmp2(:)=vec_in(:)-vec_out(:) @@ -347,12 +337,12 @@ function is_unique_set(vec1,vec2,sym) result(outval) end do symloop2 end do symloop1 - !tol=1.D-5 + !tol = 1.E-5_real32 !outval=.true. - !vec_in=(/ dble(vec1(1)), dble(vec1(2)), 0.D0/) + !vec_in=(/ real(vec1(1),real32), real(vec1(2),real32), 0._real32/) ! - !symloop1: do i=1,size(sym(:,1,1),dim=1) - ! vec_out=matmul(vec_in,sym(i,:3,:3)) + !symloop1: do i=1,size(sym,dim=3) + ! vec_out=matmul(vec_in,sym(:3,:3,i)) ! if(all(abs(vec_out-vec_in).lt.tol)) cycle symloop1 ! vec_tmp1(:)=abs(vec_in(:))-abs(vec_out(:)) ! vec_tmp2(:)=vec_in(:)-vec_out(:) @@ -380,18 +370,18 @@ function is_unique_match(sym1,sym2,check_set,test_list,lw_check,up_check,up_list implicit none integer :: i,isym,jsym integer :: nlist,matched_loc - double precision :: tol + real(real32) :: tol logical :: lunique - double precision, dimension(2,2) :: mat1,mat2,tf - double precision, dimension(2,4) :: inmat - double precision, allocatable, dimension(:,:,:) :: tf_testlist,mat_testlist + real(real32), dimension(2,2) :: mat1,mat2,tf + real(real32), dimension(2,4) :: inmat + real(real32), allocatable, dimension(:,:,:) :: tf_testlist,mat_testlist - double precision, dimension(:,:,:), intent(in) :: sym1,sym2 + real(real32), dimension(:,:,:), intent(in) :: sym1,sym2 - double precision, dimension(2,4), optional, intent(in) :: check_set - double precision, dimension(:,:,:), intent(inout), optional :: test_list - double precision, dimension(4), optional, intent(in) :: lw_check,up_check - double precision, dimension(:,:), optional, intent(inout) :: up_list + real(real32), dimension(2,4), optional, intent(in) :: check_set + real(real32), dimension(:,:,:), intent(inout), optional :: test_list + real(real32), dimension(4), optional, intent(in) :: lw_check,up_check + real(real32), dimension(:,:), optional, intent(inout) :: up_list !logical :: ltest_print !logical, optional, intent(in) :: ltest @@ -400,7 +390,7 @@ function is_unique_match(sym1,sym2,check_set,test_list,lw_check,up_check,up_list !if(present(ltest)) ltest_print=ltest !! test set - !double precision, dimension(2,2) :: test1,test2 + !real(real32), dimension(2,2) :: test1,test2 !test1(1,:) = [ 0, 1 ] !test1(2,:) = [ 3, 0 ] !test2(1,:) = [ 1, 0 ] @@ -410,7 +400,7 @@ function is_unique_match(sym1,sym2,check_set,test_list,lw_check,up_check,up_list !!!------------------------------------------------------------------------ !!! initialises tolerance and output !!!------------------------------------------------------------------------ - tol=1.D-5 + tol=1.E-5_real32 lunique = .true. @@ -452,9 +442,9 @@ function is_unique_match(sym1,sym2,check_set,test_list,lw_check,up_check,up_list !!!------------------------------------------------------------------------ allocate(tf_testlist(nlist,2,2)) do i=1,nlist - tf_testlist(i,:2,:2) = find_tf(& - mat_testlist(i,:2,:2),& - transpose(mat_testlist(i,:2,3:4))) + tf_testlist(i,:2,:2) = find_tf_2x2(& + [ mat_testlist(i,:2,:2) ],& + [ transpose(mat_testlist(i,:2,3:4)) ]) end do @@ -463,13 +453,13 @@ function is_unique_match(sym1,sym2,check_set,test_list,lw_check,up_check,up_list !!! ... when compared against the list !!!------------------------------------------------------------------------ matched_loc = 0 - sym_loop1: do isym=1,size(sym1(:,1,1)) - !mat1 = matmul(inmat(:2,:2),transpose(sym1(isym,:2,:2))) - mat1 = matmul(inmat(:2,:2),(sym1(isym,:2,:2))) - do jsym=1,size(sym2(:,1,1)) - !mat2 = matmul(inmat(:2,3:4),transpose(sym2(jsym,:2,:2))) - mat2 = matmul(inmat(:2,3:4),(sym2(jsym,:2,:2))) - tf = find_tf(mat1,transpose(mat2)) + sym_loop1: do isym = 1, size(sym1,dim=3), 1 + !mat1 = matmul(inmat(:2,:2),transpose(sym1(:2,:2,isym))) + mat1 = matmul(inmat(:2,:2),(sym1(:2,:2,isym))) + do jsym = 1, size(sym2,dim=3), 1 + !mat2 = matmul(inmat(:2,3:4),transpose(sym2(:2,:2,jsym))) + mat2 = transpose(matmul(inmat(:2,3:4),(sym2(:2,:2,jsym)))) + tf = find_tf_2x2(mat1,mat2) !if(ltest_print)then !!if(any(ISNAN(tf)))then !!if(all(abs(inmat(:2,:2)-test1).lt.tol))then @@ -477,9 +467,9 @@ function is_unique_match(sym1,sym2,check_set,test_list,lw_check,up_check,up_list ! ! all(abs(inmat(:2,3:4)-test2).lt.tol))then ! write(0,*) isym,jsym ! - ! write(0,'(2(2X,F7.3))') sym1(isym,:2,:2) + ! write(0,'(2(2X,F7.3))') sym1(:2,:2,isym) ! write(0,*) - ! write(0,'(2(2X,F7.3))') sym2(jsym,:2,:2) + ! write(0,'(2(2X,F7.3))') sym2(:2,:2,jsym) ! write(0,*) "mat1" ! write(0,'(2(2X,F7.3))') mat1 ! write(0,*) "mat2" @@ -489,8 +479,8 @@ function is_unique_match(sym1,sym2,check_set,test_list,lw_check,up_check,up_list ! write(0,*) ! !! !if(isym.eq.1) stop - !! !if(jsym.eq.size(sym2(:,1,1))) stop - !! !if(isym.eq.size(sym1(:,1,1))) stop + !! !if(jsym.eq.size(sym2,dim=3)) stop + !! !if(isym.eq.size(sym1,dim=3)) stop !! !stop !end if @@ -525,10 +515,10 @@ function is_unique_match(sym1,sym2,check_set,test_list,lw_check,up_check,up_list !!! saves the smallest match if successful !!!------------------------------------------------------------------------ if(.not.lunique)then - if(abs(get_area(inmat(:2,:2),inmat(:2,3:4))).lt.& + if(abs(get_area([ inmat(:2,:2) ], [ inmat(:2,3:4) ])).lt.& abs(& - get_area(mat_testlist(matched_loc,:2,:2),& - mat_testlist(matched_loc,:2,3:4))))then + get_area([ mat_testlist(matched_loc,:2,:2) ],& + [ mat_testlist(matched_loc,:2,3:4) ])))then mat_testlist(matched_loc,:2,:4) = inmat(:2,:4) if(present(test_list))then test_list = mat_testlist @@ -569,32 +559,31 @@ subroutine cell_match(& transforms1,transforms2,& ntransforms,matched_tols,sym1,sym2) implicit none - integer :: i,j,l,m,total_list_count,nvec1,nvec2, k - real :: tol_up_ang,tol_dw_ang,tol_up_vec,tol_dw_vec - double precision :: tiny - double precision :: reference_mag,considered_mag - double precision :: reference_angle,considered_angle - type(pm_tol_type) :: tol - double precision, dimension(3) :: lat1_veca,lat1_vecb,lat2_veca,lat2_vecb - double precision, dimension(tol%maxfit) :: MAIN_LOOP_LIST_TOLERANCES - !double precision, dimension(:) :: MAIN_LOOP_LIST_TOLERANCES + integer :: i,j,l,m,total_list_count,nvec1,nvec2 + real(real32) :: tol_up_ang,tol_dw_ang,tol_up_vec,tol_dw_vec + real(real32) :: tiny + real(real32) :: reference_mag,considered_mag + real(real32) :: reference_angle,considered_angle + type(tol_type) :: tol + real(real32), dimension(3) :: lat1_veca,lat1_vecb,lat2_veca,lat2_vecb, unit_vec + real(real32), dimension(tol%maxfit) :: MAIN_LOOP_LIST_TOLERANCES integer, dimension(2,6) :: tmpmat - double precision, dimension(2,2) :: tf,mat1,mat2 - double precision, dimension(2,3) :: considered_vectors - double precision, dimension(3,3) :: lat1,lat2 - double precision, dimension(1000,3) :: tmp_tolerances - double precision, allocatable, dimension(:,:) :: matched_tols - double precision, dimension(tol%maxfit,2,4) :: MAIN_LOOP_LIST - - integer :: ntransforms + real(real32), dimension(2,2) :: tf,mat1,mat2 + real(real32), dimension(2,3) :: considered_vectors + real(real32), dimension(3,3), intent(in) :: lat1,lat2 + real(real32), dimension(1000,3) :: tmp_tolerances + real(real32), allocatable, dimension(:,:), intent(out) :: matched_tols + real(real32), dimension(tol%maxfit,2,4) :: MAIN_LOOP_LIST + + integer, intent(out) :: ntransforms !! The 2x2 transformation matrices output by the code. !! allocated when we know how many fits. - integer, allocatable, dimension(:,:,:) :: transforms1,transforms2 + integer, allocatable, dimension(:,:,:), intent(out) :: transforms1,transforms2 integer, allocatable, dimension(:,:) :: numstore_1,numstore_2 integer, allocatable, dimension(:,:) :: iarrtmp1 - double precision, allocatable, dimension(:,:) :: latstore_1,latstore_2 - double precision, allocatable, dimension(:,:) :: darrtmp1 - double precision, dimension(:,:,:), optional :: sym1,sym2 + real(real32), allocatable, dimension(:,:) :: latstore_1,latstore_2 + real(real32), allocatable, dimension(:,:) :: darrtmp1 + real(real32), dimension(:,:,:), intent(in), optional :: sym1,sym2 !!! Layout of each of the 1000 cells: @@ -611,13 +600,13 @@ subroutine cell_match(& integer :: len_list_final !Length of final list of compatible vector pairs after angle check !! list of vec combins (of 2a and 2b) that fit vec lat1_a, mag of tol on fit - double precision, dimension(1000,3) :: list_1a + real(real32), dimension(1000,3) :: list_1a !! layout: int num of lat2_a, int num of lat2_b, tol !! list of vec combins (of 2a and 2b) that fit vec lat1_b, mag of tol on fit - double precision, dimension(1000,3) :: list_1b + real(real32), dimension(1000,3) :: list_1b !! layout: integer number of lat2_a, integer number of lat2_b, tol - double precision, dimension(1000,5) :: list_angle_fits + real(real32), dimension(1000,5) :: list_angle_fits !Layout: ! First 2 components(1-2); integer number of lat2_a, integer number of lat2_b ! Next 2 components(3-4); integer number of lat2_a, integer number of lat2_b @@ -627,11 +616,11 @@ subroutine cell_match(& !!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!! Setting up tolerances !!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!! - tiny = 1.D-5 - tol_up_ang = 1.E0 + real(tol%ang)/(2.E0*pi) - tol_dw_ang = 1.E0 - real(tol%ang)/(2.E0*pi) - tol_up_vec = 1.E0 + real(tol%vec)!/100.D0 - tol_dw_vec = 1.E0 - real(tol%vec)!/100.D0 + tiny = 1.E-5_real32 + tol_up_ang = 1._real32 + tol%ang/(2._real32*pi) + tol_dw_ang = 1._real32 - tol%ang/(2._real32*pi) + tol_up_vec = 1._real32 + tol%vec!/100._real32 + tol_dw_vec = 1._real32 - tol%vec!/100._real32 if(allocated(matched_tols)) deallocate(matched_tols) allocate(matched_tols(tol%maxfit,3)) @@ -664,9 +653,9 @@ subroutine cell_match(& if (l.eq.0 .and. m.eq.0) cycle vecmakeloop2 pmloop2: do j=1,-1,-2 nvec1=nvec1+1 - numstore_1(nvec1,:) = (/ i*l, j*m /) - latstore_1(nvec1,:) = dble(i*l) * lat1_veca + dble(j*m) * lat1_vecb - if(abs(modu(latstore_1(nvec1,:))).gt.tol%maxlen)then + numstore_1(nvec1,:) = [ i*l, j*m ] + latstore_1(nvec1,:) = real(i*l,real32) * lat1_veca + real(j*m,real32) * lat1_vecb + if(abs(modu([latstore_1(nvec1,:)])).gt.tol%maxlen)then nvec1=nvec1-1 cycle pmloop1 end if @@ -695,10 +684,10 @@ subroutine cell_match(& pmloop4: do j=1,-1,-2 nvec2=nvec2+1 numstore_2(nvec2,:) = (/ i*l, j*m /) - latstore_2(nvec2,:) = dble(i*l) * lat2_veca + dble(j*m) * lat2_vecb + latstore_2(nvec2,:) = real(i*l,real32) * lat2_veca + real(j*m,real32) * lat2_vecb if(modu(latstore_2(nvec2,:)).gt.tol%maxlen)then nvec2=nvec2-1 - cycle vecmakeloop3 + cycle pmloop3 end if end do pmloop4 end do vecmakeloop4 @@ -718,6 +707,7 @@ subroutine cell_match(& total_list_count = 0 MAINLOOP1: do l=1,nvec1 tmpmat(1,:2) = numstore_1(l,:2) + unit_vec = uvec(real(numstore_1(l,:2), real32)) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -744,17 +734,19 @@ subroutine cell_match(& !!! lower lattice vector 2 loop !!!------------------------------------------------------------------------ MAINLOOP2: do m=1,nvec1 + if(all(abs(unit_vec-uvec(real(numstore_1(m,:2), real32))).lt.1.E-6_real32)) cycle MAINLOOP2 + if(all(abs(unit_vec+uvec(real(numstore_1(m,:2), real32))).lt.1.E-6_real32)) cycle MAINLOOP2 tmpmat(2,:2) = numstore_1(m,:2) if(all(latstore_1(l,:).eq.latstore_1(m,:))) cycle MAINLOOP2 - if(get_area(latstore_1(l,:),latstore_1(m,:)).gt.tol%maxarea) cycle MAINLOOP2 - if(all(cross(latstore_1(l,:),latstore_1(m,:)).eq.0.D0)) cycle MAINLOOP2 - reference_angle = get_angle(latstore_1(l,:),latstore_1(m,:)) + if(get_area([latstore_1(l,:)],[latstore_1(m,:)]).gt.tol%maxarea) cycle MAINLOOP2 + if(all(cross([latstore_1(l,:)],[latstore_1(m,:)]).lt.1.E-6_real32)) cycle MAINLOOP2 + reference_angle = get_angle([latstore_1(l,:)],[latstore_1(m,:)]) if (abs(reference_angle) .lt. tiny) cycle MAINLOOP2 !!! CHANGE IT TO TAKE IN A 2x2 MATRIX LATER !!! if(modu(latstore_1(l,:)).gt.modu(latstore_1(m,:))) cycle MAINLOOP2 if(dot_product(latstore_1(l,:),latstore_1(m,:)).gt.& - (0.5D0*dot_product(latstore_1(l,:),latstore_1(l,:))))& + (0.5_real32*dot_product(latstore_1(l,:),latstore_1(l,:))))& cycle MAINLOOP2 !SHOULD I REMOVE THIS? WHAT DOES IT WANT TO DO? !if(.not.is_unique_set(numstore_1(l,:),numstore_1(m,:),sym1)) & @@ -791,7 +783,7 @@ subroutine cell_match(& considered_vectors(1,:) = list_1a(i,1)*lat2_veca + list_1a(i,2)*lat2_vecb considered_vectors(2,:) = list_1b(j,1)*lat2_veca + list_1b(j,2)*lat2_vecb considered_angle = & - get_angle(considered_vectors(1,:),considered_vectors(2,:)) + get_angle([considered_vectors(1,:)],[considered_vectors(2,:)]) !if(.not.is_unique_set(nint(list_1a(i,:2)),nint(list_1b(j,:2)),sym2)) & ! cycle loop110 !!-------------------------------------------------------------------------- @@ -804,22 +796,18 @@ subroutine cell_match(& cycle loop110 else tmpmat(2,3:4) = nint(list_1b(j,:2)) - !write(0,'(A,4X,"[",I3,I3,",",I3,I3,"]",6X,"[",I3,I3,",",I3,I3,"]",4X,I2,2X,I2,2X,F0.3)') & - ! "HERE",numstore_1(l,:2),numstore_1(m,:2),nint(list_1a(i,:2)),nint(list_1b(j,:2)),& - ! total_list_count,len_list_final, considered_angle if(total_list_count.ne.0)then if(.not.is_unique_match( sym1, sym2, & - check_set = dble(tmpmat),& + check_set = real(tmpmat,real32),& test_list = MAIN_LOOP_LIST(:total_list_count,:2,:4)))& cycle loop110 end if if(len_list_final.ne.0)then if(.not.is_unique_match( sym1, sym2, & - check_set = dble(tmpmat),& + check_set = real(tmpmat,real32),& up_list = list_angle_fits(:len_list_final,:4)))& cycle loop110 end if - !write(0,*) "PAST HERE", list_angle_fits(len_list_final,:) len_list_final = len_list_final + 1 list_angle_fits(len_list_final,1:2) = list_1a(i,1:2) @@ -828,13 +816,13 @@ subroutine cell_match(& max(list_1a(i,3),list_1b(j,3)) tmp_tolerances(len_list_final,2) = & abs(considered_angle-reference_angle) - tmp_tolerances(len_list_final,3) = abs(1.D0 - & - get_area(considered_vectors(1,:),considered_vectors(2,:))& - /get_area(latstore_1(l,:),latstore_1(m,:))) + tmp_tolerances(len_list_final,3) = abs(1._real32 - & + get_area([considered_vectors(1,:)],[considered_vectors(2,:)])& + /get_area([latstore_1(l,:)],[latstore_1(m,:)])) list_angle_fits(len_list_final,5) = & tol%ang_weight * abs(considered_angle-reference_angle) + & list_1a(i,3) + list_1b(i,3) + & - tol%area_weight*get_area(latstore_1(l,:),latstore_1(m,:)) + tol%area_weight*get_area([latstore_1(l,:)],[latstore_1(m,:)]) end if end do loop110 end do loop109 @@ -845,14 +833,14 @@ subroutine cell_match(& !!! output list down to that size !!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! loop112: do i=1, len_list_final - mat1(1,:2)=dble(numstore_1(l,:2)) - mat1(2,:2)=dble(numstore_1(m,:2)) - mat2(1,:2)=dble(list_angle_fits(i,1:2)) - mat2(2,:2)=dble(list_angle_fits(i,3:4)) - tf=find_tf(mat1,mat2) + mat1(1,:2)=real(numstore_1(l,:2),real32) + mat1(2,:2)=real(numstore_1(m,:2),real32) + mat2(1,:2)=real(list_angle_fits(i,1:2),real32) + mat2(2,:2)=real(list_angle_fits(i,3:4),real32) + tf=find_tf_2x2(mat1,mat2) do j=1,tol%maxfit - if(all(abs(tf-find_tf(dble(MAIN_LOOP_LIST(j,:2,1:2)),& - dble(MAIN_LOOP_LIST(j,:2,3:4)))).lt.1.D-6))then + if(all(abs(tf-find_tf_2x2( [ MAIN_LOOP_LIST(j,:2,1:2) ],& + [ MAIN_LOOP_LIST(j,:2,3:4) ] )).lt.1.E-6_real32))then cycle loop112 end if end do diff --git a/src/mod_shifting.f90 b/src/fortran/lib/mod_shifting.f90 similarity index 77% rename from src/mod_shifting.f90 rename to src/fortran/lib/mod_shifting.f90 index cbc03ca..f324a50 100644 --- a/src/mod_shifting.f90 +++ b/src/fortran/lib/mod_shifting.f90 @@ -4,17 +4,18 @@ !!! Think Hepplestone, think HRG. !!!############################################################################# module shifting - use constants, only: ierror,pi,INF + use artemis__constants, only: real32, pi, INF use misc_maths, only: get_nth_plane use misc_linalg, only: modu - use rw_geom, only: bas_type,clone_bas,geom_write - use edit_geom, only: split_bas,get_centre_atom,bas_merge,set_vacuum,shifter - use io - use interface_identifier + use artemis__geom_rw, only: basis_type,geom_write + use artemis__geom_utils, only: split_bas,get_centre_atom,set_vacuum,shifter + use artemis__io_utils + use artemis__io_utils_extd, only: err_abort_print_struc + use artemis__interface_identifier implicit none - real :: f_scale = 0.5 - real :: g_scale = 8.0/3.0 + real(real32) :: f_scale = 0.5_real32 + real(real32) :: g_scale = 8._real32/3._real32 private @@ -40,15 +41,15 @@ module shifting subroutine get_top_bot_basis(lat,bas,bas_top,bas_bot,axis,intf_loc,depth) implicit none integer :: i,is,ia,itop,ibot,axis,count1 - double precision :: centre,dist,dist_max - double precision, optional :: depth - type(bas_type) :: bas,bas_top,bas_bot - double precision, dimension(:) :: intf_loc - double precision, dimension(3,3) :: lat + real(real32) :: centre,dist,dist_max + real(real32), optional :: depth + type(basis_type) :: bas,bas_top,bas_bot + real(real32), dimension(:) :: intf_loc + real(real32), dimension(3,3) :: lat integer, allocatable, dimension(:) :: vtmp1 integer, allocatable, dimension(:,:) :: intf_list - double precision, allocatable, dimension(:,:) :: regions - type(bas_type), allocatable, dimension(:) :: splitbas + real(real32), allocatable, dimension(:,:) :: regions + type(basis_type), allocatable, dimension(:) :: splitbas !!!----------------------------------------------------------------------------- @@ -90,8 +91,8 @@ subroutine get_top_bot_basis(lat,bas,bas_top,bas_bot,axis,intf_loc,depth) LOOP105: do is=1,bas%nspec allocate(bas_top%spec(is)%atom(bas_top%spec(is)%num,3)) allocate(bas_bot%spec(is)%atom(bas_bot%spec(is)%num,3)) - bas_top%spec(is)%atom(:,:)=0.D0 - bas_bot%spec(is)%atom(:,:)=0.D0 + bas_top%spec(is)%atom(:,:)=0._real32 + bas_bot%spec(is)%atom(:,:)=0._real32 end do LOOP105 @@ -114,7 +115,7 @@ subroutine get_top_bot_basis(lat,bas,bas_top,bas_bot,axis,intf_loc,depth) end do LOOP104 end do LOOP103 else - dist_max=4.D0/modu(lat(axis,:)) + dist_max=4._real32/modu(lat(axis,:)) allocate(vtmp1(bas%nspec)) allocate(regions(size(intf_loc,dim=1),2)) regions(1,1:2)=intf_loc(1:2) @@ -125,7 +126,7 @@ subroutine get_top_bot_basis(lat,bas,bas_top,bas_bot,axis,intf_loc,depth) !!----------------------------------------------------------------------- !! Finds lower interfacial atoms near interface defined by intf_loc(1) !!----------------------------------------------------------------------- - intf_list=gen_DONsim(gen_DON(lat,splitbas(1)),cutoff=4.0) + intf_list=gen_DONsim(gen_DON(lat,splitbas(1)),cutoff=4._real32) 101 do is=1,bas%nspec bas_bot%sysname=splitbas(1)%sysname bas_bot%spec(is)%name=splitbas(1)%spec(is)%name @@ -155,7 +156,7 @@ subroutine get_top_bot_basis(lat,bas,bas_top,bas_bot,axis,intf_loc,depth) !! ... method 2 !!----------------------------------------------------------------------- if(bas_bot%natom.eq.0)then - intf_list=gen_DONsim(gen_DON(lat,splitbas(1)),cutoff=4.0,avg_mthd=2) + intf_list=gen_DONsim(gen_DON(lat,splitbas(1)),cutoff=4._real32,avg_mthd=2) do is=1,bas%nspec deallocate(bas_bot%spec(is)%atom) end do @@ -166,7 +167,7 @@ subroutine get_top_bot_basis(lat,bas,bas_top,bas_bot,axis,intf_loc,depth) !!----------------------------------------------------------------------- !! Finds upper interfacial atoms near interface defined by intf_loc(1) !!----------------------------------------------------------------------- - intf_list=gen_DONsim(gen_DON(lat,splitbas(2)),cutoff=4.0) + intf_list=gen_DONsim(gen_DON(lat,splitbas(2)),cutoff=4._real32) 102 do is=1,bas%nspec bas_top%sysname=splitbas(2)%sysname bas_top%spec(is)%name=splitbas(2)%spec(is)%name @@ -196,7 +197,7 @@ subroutine get_top_bot_basis(lat,bas,bas_top,bas_bot,axis,intf_loc,depth) !! ... method 2 !!----------------------------------------------------------------------- if(bas_top%natom.eq.0)then - intf_list=gen_DONsim(gen_DON(lat,splitbas(2)),cutoff=4.0,avg_mthd=2) + intf_list=gen_DONsim(gen_DON(lat,splitbas(2)),cutoff=4._real32,avg_mthd=2) do is=1,bas%nspec deallocate(bas_top%spec(is)%atom) end do @@ -215,23 +216,23 @@ end subroutine get_top_bot_basis !!! ... required minimum bulk bond length. !!!############################################################################# function get_fit_shifts(lat,bas,bond,axis,intf_loc,depth,nstore,itmp1,itmp2) result(best_shifts) - double precision :: depth,bond ! the depth into the material we are interested (physical size in the c direction). + real(real32) :: depth,bond ! the depth into the material we are interested (physical size in the c direction). integer :: i - type(bas_type) :: bas_bot,bas_top + type(basis_type) :: bas_bot,bas_top - double precision :: depth_bascoord - double precision, dimension(:) :: intf_loc - double precision, allocatable, dimension(:,:) :: min_atom_sep - double precision, allocatable, dimension(:,:,:) :: avg_min_atom_sep + real(real32) :: depth_bascoord + real(real32), dimension(:) :: intf_loc + real(real32), allocatable, dimension(:,:) :: min_atom_sep + real(real32), allocatable, dimension(:,:,:) :: avg_min_atom_sep integer :: axis integer :: num_steps,num_c_shifts !number of pieces to divide the unit cell into in a and b direction. - double precision, allocatable, dimension(:,:) :: best_shifts + real(real32), allocatable, dimension(:,:) :: best_shifts integer :: nstore ! The required output number of the best shifts. integer, optional :: itmp1,itmp2 - type(bas_type) :: bas !The basis input by interfaces.f90 - double precision, dimension(3,3) :: lat !The lattice input by interfaces.f90 + type(basis_type) :: bas !The basis input by interfaces.f90 + real(real32), dimension(3,3) :: lat !The lattice input by interfaces.f90 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -245,7 +246,7 @@ function get_fit_shifts(lat,bas,bond,axis,intf_loc,depth,nstore,itmp1,itmp2) res allocate(best_shifts(nstore,4)) - if(depth.eq.0.D0)then + if(depth.eq.0._real32)then call get_top_bot_basis(lat,bas,bas_top,bas_bot,axis,intf_loc) else call get_top_bot_basis(lat,bas,bas_top,bas_bot,axis,intf_loc,depth) @@ -277,7 +278,7 @@ function get_fit_shifts(lat,bas,bond,axis,intf_loc,depth,nstore,itmp1,itmp2) res ! close(unit) ! end do - write(6,'(4(F0.5,2X))') (best_shifts(i,:),i=1,nstore) + write(*,'(4(F0.5,2X))') (best_shifts(i,:),i=1,nstore) end function get_fit_shifts !!!######################################################################### @@ -289,10 +290,10 @@ end function get_fit_shifts !!!######################################################################### function findbestfits(bulkbond,avg_min_sep,num_steps,num_c_shifts,num_best_shifts,depth) result(best_shifts) implicit none - double precision, dimension(:,:,:) :: avg_min_sep - double precision :: bulkbond,current_difference,min_difference,depth + real(real32), dimension(:,:,:) :: avg_min_sep + real(real32) :: bulkbond,current_difference,min_difference,depth integer :: i,ia,ib,ic,num_steps,num_c_shifts,num_best_shifts,c_shift_low,c_shift_high - double precision, allocatable, dimension(:,:) :: best_shifts + real(real32), allocatable, dimension(:,:) :: best_shifts integer, dimension(3) :: placeholder allocate(best_shifts(num_best_shifts,4)) @@ -306,26 +307,30 @@ function findbestfits(bulkbond,avg_min_sep,num_steps,num_c_shifts,num_best_shift end if shiftloop: do i=1,num_best_shifts - min_difference = huge(0.D0) + placeholder = -1 + min_difference = huge(0._real32) LOOP5A: do ia=0,num_steps-1 !loop through shifts in a LOOP5B: do ib=0,num_steps-1 !loop through shifts in b LOOP5C: do ic=c_shift_low,c_shift_high,1 !Loop through shifts of the top plane in c current_difference = abs(avg_min_sep(ia+1,ib+1,ic-c_shift_low+1) - bulkbond) if (current_difference.lt.min_difference) then min_difference = current_difference - best_shifts(i,1) = dble(ia)/dble(num_steps) - best_shifts(i,2) = dble(ib)/dble(num_steps) - best_shifts(i,3) = dble(ic)*depth*2.D0/dble(num_c_shifts) + best_shifts(i,1) = real(ia,real32)/real(num_steps,real32) + best_shifts(i,2) = real(ib,real32)/real(num_steps,real32) + best_shifts(i,3) = real(ic,real32)*depth*2._real32/real(num_c_shifts,real32) best_shifts(i,4) = min_difference placeholder(1) = ia placeholder(2) = ib placeholder(3) = ic - end if end do LOOP5C end do LOOP5B end do LOOP5A - avg_min_sep(placeholder(1)+1,placeholder(2)+1,placeholder(3)-c_shift_low+1) = huge(0.D0) + if(any(placeholder.eq.-1)) then + write(0,*) "ERROR: No shifts found for the given interface" + stop + end if + avg_min_sep(placeholder(1)+1,placeholder(2)+1,placeholder(3)-c_shift_low+1) = huge(0._real32) end do shiftloop end function findbestfits @@ -338,17 +343,17 @@ end function findbestfits !!!############################################################################# function avgminsep(lat,plane_up,plane_dw,num_steps,num_c_shifts,depth) result(avg_min_sep) implicit none - type(bas_type) :: plane_up,plane_dw,tplane_up,tplane_dw - double precision :: avg_sep_up,avg_sep_dw,depth + type(basis_type) :: plane_up,plane_dw,tplane_up,tplane_dw + real(real32) :: avg_sep_up,avg_sep_dw,depth integer :: num_steps,num_c_shifts !number of pieces to divide the unit cell into in a and b direction. - double precision, allocatable, dimension(:,:,:) :: avg_min_sep + real(real32), allocatable, dimension(:,:,:) :: avg_min_sep integer :: ia,ib,ic,is_up,ia_up,c_shift_low,c_shift_high - double precision, dimension(3,3) :: lat + real(real32), dimension(3,3) :: lat allocate(avg_min_sep(num_steps,num_steps,num_c_shifts)) - call clone_bas(plane_up,tplane_up) - call clone_bas(plane_dw,tplane_dw) + call tplane_up%copy(plane_up) + call tplane_dw%copy(plane_dw) if (mod(num_c_shifts,2) .eq. 0) then c_shift_low = -nint(real(num_c_shifts)/2.0)+1 c_shift_high = nint(real(num_c_shifts)/2.0) @@ -358,7 +363,7 @@ function avgminsep(lat,plane_up,plane_dw,num_steps,num_c_shifts,depth) result(av end if - avg_min_sep = huge(0.D0) + avg_min_sep = huge(0._real32) LOOP4C: do ic=c_shift_low,c_shift_high,1 !Loop through shifts of the top plane in c LOOP4A: do ia=0,num_steps-1 !loop through shifts in a LOOP4B: do ib=0,num_steps-1 !loop through shifts in b @@ -368,9 +373,9 @@ function avgminsep(lat,plane_up,plane_dw,num_steps,num_c_shifts,depth) result(av plane_up%spec(is_up)%atom(ia_up,:) = & plane_up%spec(is_up)%atom(ia_up,:) + & (/& - (dble(ia)/dble(num_steps)),& - (dble(ib)/dble(num_steps)),& - (dble(ic)*depth*2.D0/dble(num_c_shifts)) /) + (real(ia,real32)/real(num_steps,real32)),& + (real(ib,real32)/real(num_steps,real32)),& + (real(ic,real32)*depth*2._real32/real(num_c_shifts,real32)) /) end do end do @@ -378,7 +383,7 @@ function avgminsep(lat,plane_up,plane_dw,num_steps,num_c_shifts,depth) result(av avg_sep_dw = find_avg_min_sep(lat, plane_dw,tplane_up) avg_min_sep(ia+1,ib+1,ic-c_shift_low+1) = & - (avg_sep_up + avg_sep_dw)/2.D0 + (avg_sep_up + avg_sep_dw)/2._real32 end do LOOP4B end do LOOP4A @@ -395,17 +400,17 @@ end function avgminsep function find_avg_min_sep(lat,plane_1,plane_2) result(avg_min_sep) implicit none integer :: is_1,ia_1,is_2,ia_2,j - double precision :: avg_min_sep,min_sep,cur_sep - type(bas_type) :: plane_1,plane_2 - double precision, dimension(3) :: dvtmp1 - double precision, dimension(3,3) :: lat + real(real32) :: avg_min_sep,min_sep,cur_sep + type(basis_type) :: plane_1,plane_2 + real(real32), dimension(3) :: dvtmp1 + real(real32), dimension(3,3) :: lat - avg_min_sep=0.D0 + avg_min_sep=0._real32 LOOP401: do is_1=1,plane_1%nspec ! Loop though 1st plane LOOP402: do ia_1=1,plane_1%spec(is_1)%num - min_sep = huge(0.D0) + min_sep = huge(0._real32) LOOP403: do is_2=1,plane_2%nspec ! Loop through 2nd plane LOOP404: do ia_2=1,plane_2%spec(is_2)%num @@ -414,7 +419,7 @@ function find_avg_min_sep(lat,plane_1,plane_2) result(avg_min_sep) plane_1%spec(is_1)%atom(ia_1,:) do j=1,3 - dvtmp1(j) = dvtmp1(j) - ceiling( dvtmp1(j) - 0.5D0 ) + dvtmp1(j) = dvtmp1(j) - ceiling( dvtmp1(j) - 0.5_real32 ) end do dvtmp1 = dvtmp1(1) * lat(1,:) & + dvtmp1(2) * lat(2,:) & @@ -455,13 +460,13 @@ function get_descriptive_shifts(lat,bas,bond,axis,intf_loc,depth,nstore,c_scale, implicit none integer :: is integer :: nstore,axis,num_steps - double precision :: bond,depth,cur_vac,c_shift - type(bas_type) :: bas,bas_bot,bas_top - double precision, dimension(3,3) :: lat - double precision, dimension(:) :: intf_loc - double precision, allocatable, dimension(:) :: specval_bot,specval_top - double precision, allocatable, dimension(:,:) :: res_shifts - double precision, optional :: c_scale + real(real32) :: bond,depth,cur_vac,c_shift + type(basis_type) :: bas,bas_bot,bas_top + real(real32), dimension(3,3) :: lat + real(real32), dimension(:) :: intf_loc + real(real32), allocatable, dimension(:) :: specval_bot,specval_top + real(real32), allocatable, dimension(:,:) :: res_shifts + real(real32), optional :: c_scale logical, optional :: lprint @@ -470,7 +475,7 @@ function get_descriptive_shifts(lat,bas,bond,axis,intf_loc,depth,nstore,c_scale, !!!----------------------------------------------------------------------------- !!! separates basis into atoms above and below interface within a depth window !!!----------------------------------------------------------------------------- - if(depth.eq.0.D0)then + if(depth.eq.0._real32)then call get_top_bot_basis(lat,bas,bas_top,bas_bot,axis,intf_loc) else call get_top_bot_basis(lat,bas,bas_top,bas_bot,axis,intf_loc,depth=depth) @@ -482,8 +487,8 @@ function get_descriptive_shifts(lat,bas,bond,axis,intf_loc,depth,nstore,c_scale, !!!----------------------------------------------------------------------------- allocate(specval_bot(bas%nspec)) allocate(specval_top(bas%nspec)) - specval_bot=-huge(0.D0) - specval_top=huge(0.D0) + specval_bot=-huge(0._real32) + specval_top=huge(0._real32) do is=1,bas%nspec if(bas_bot%spec(is)%num.ne.0)then specval_bot(is)=maxval(bas_bot%spec(is)%atom(:,axis)) @@ -519,9 +524,9 @@ function get_descriptive_shifts(lat,bas,bond,axis,intf_loc,depth,nstore,c_scale, if(present(lprint))then if(lprint)then - write(6,'(1X,"Shifts to be applied (Å)")') + write(*,'(1X,"Shifts to be applied (Å)")') do is=1,nstore - write(6,*) res_shifts(is,1),res_shifts(is,2), & + write(*,*) res_shifts(is,1),res_shifts(is,2), & res_shifts(is,3)*modu(lat(axis,:)) end do end if @@ -545,30 +550,30 @@ function get_c_shift(lat,plane_up,plane_dw,bond,axis,num_steps) result(c_shift) implicit none integer :: num_steps,count1 integer :: ia,ib,is_up,ia_up,axis - double precision :: avg_sep_up,avg_sep_dw,bond,tol - double precision :: c_shift,prev_c_shift,new_c_shift - double precision :: prev_min_bond,min_bond - type(bas_type) :: plane_up,plane_dw,tplane_up - double precision, allocatable, dimension(:,:) :: avg_min_sep - double precision, dimension(3,3) :: lat + real(real32) :: avg_sep_up,avg_sep_dw,bond,tol + real(real32) :: c_shift,prev_c_shift,new_c_shift + real(real32) :: prev_min_bond,min_bond + type(basis_type) :: plane_up,plane_dw,tplane_up + real(real32), allocatable, dimension(:,:) :: avg_min_sep + real(real32), dimension(3,3) :: lat !!!----------------------------------------------------------------------------- !!! Clone upper basis for editing !!!----------------------------------------------------------------------------- - call clone_bas(plane_up,tplane_up) + call tplane_up%copy(plane_up) allocate(avg_min_sep(num_steps,num_steps)) !!!----------------------------------------------------------------------------- !!! Initialise variables !!!----------------------------------------------------------------------------- - tol=1.D-2/modu(lat(axis,:)) + tol=1.E-2_real32/modu(lat(axis,:)) count1=0 - prev_min_bond=0.D0 - prev_c_shift=0.D0 - c_shift=0.D0 - avg_min_sep = huge(0.D0) + prev_min_bond=0._real32 + prev_c_shift=0._real32 + c_shift=0._real32 + avg_min_sep = huge(0._real32) !!!----------------------------------------------------------------------------- @@ -584,15 +589,15 @@ function get_c_shift(lat,plane_up,plane_dw,bond,axis,num_steps) result(c_shift) do ia_up=1,plane_up%spec(is_up)%num tplane_up%spec(is_up)%atom(ia_up,:) = plane_up%spec(is_up)%atom(ia_up,:) + & (/& - (dble(ia)/dble(num_steps)),& - (dble(ib)/dble(num_steps)),& + (real(ia,real32)/real(num_steps,real32)),& + (real(ib,real32)/real(num_steps,real32)),& c_shift /) end do end do avg_sep_up = find_avg_min_sep(lat,tplane_up, plane_dw) avg_sep_dw = find_avg_min_sep(lat, plane_dw,tplane_up) - avg_min_sep(ia+1,ib+1) = (avg_sep_up + avg_sep_dw)/2.D0 + avg_min_sep(ia+1,ib+1) = (avg_sep_up + avg_sep_dw)/2._real32 end do LOOP5B end do LOOP5A @@ -618,7 +623,7 @@ function get_c_shift(lat,plane_up,plane_dw,bond,axis,num_steps) result(c_shift) (prev_c_shift - c_shift)*( prev_min_bond - bond )/( prev_min_bond - min_bond ) end if else - new_c_shift = 0.5D0/modu(lat(axis,:)) + new_c_shift = 0.5_real32/modu(lat(axis,:)) end if !!----------------------------------------------------------------------- !! Breaks afer 50 failed steps @@ -651,21 +656,21 @@ function get_descriptive_ab_shifts(lat,plane_up,plane_dw,bond,axis,nstore,num_st implicit none integer :: nstore,num_steps,count1 integer :: ia,ib,is_up,ia_up,axis,iden,inum - double precision :: avg_sep_up,avg_sep_dw,bond - double precision :: min_sep,max_sep - type(bas_type) :: plane_up,plane_dw,tplane_up,tplane_dw - double precision, allocatable, dimension(:,:) :: ab_shifts,avg_min_sep - double precision, dimension(3,3) :: lat + real(real32) :: avg_sep_up,avg_sep_dw,bond + real(real32) :: min_sep,max_sep + type(basis_type) :: plane_up,plane_dw,tplane_up,tplane_dw + real(real32), allocatable, dimension(:,:) :: ab_shifts,avg_min_sep + real(real32), dimension(3,3) :: lat - call clone_bas(plane_up,tplane_up) - call clone_bas(plane_dw,tplane_dw) + call tplane_up%copy(plane_up) + call tplane_dw%copy(plane_dw) allocate(avg_min_sep(num_steps,num_steps)) allocate(ab_shifts(nstore,2)) count1=0 - avg_min_sep = huge(0.D0) + avg_min_sep = huge(0._real32) LOOP5A: do ia=0,num_steps-1 !loop through shifts in a LOOP5B: do ib=0,num_steps-1 !loop through shifts in b @@ -673,9 +678,9 @@ function get_descriptive_ab_shifts(lat,plane_up,plane_dw,bond,axis,nstore,num_st do ia_up=1,plane_up%spec(is_up)%num tplane_up%spec(is_up)%atom(ia_up,:) = plane_up%spec(is_up)%atom(ia_up,:) + & (/& - (dble(ia)/dble(num_steps)),& - (dble(ib)/dble(num_steps)),& - 0.D0 /) + (real(ia,real32)/real(num_steps,real32)),& + (real(ib,real32)/real(num_steps,real32)),& + 0._real32 /) end do end do @@ -683,7 +688,7 @@ function get_descriptive_ab_shifts(lat,plane_up,plane_dw,bond,axis,nstore,num_st avg_sep_dw = find_avg_min_sep(lat, plane_dw,tplane_up) - avg_min_sep(ia+1,ib+1) = (avg_sep_up + avg_sep_dw)/2.D0 + avg_min_sep(ia+1,ib+1) = (avg_sep_up + avg_sep_dw)/2._real32 end do LOOP5B end do LOOP5A @@ -694,8 +699,8 @@ function get_descriptive_ab_shifts(lat,plane_up,plane_dw,bond,axis,nstore,num_st - ab_shifts(1,:)=dble((/minloc(avg_min_sep)/))/dble(num_steps) - ab_shifts(2,:)=dble((/maxloc(avg_min_sep)/))/dble(num_steps) + ab_shifts(1,:)=real((/minloc(avg_min_sep)/),real32)/real(num_steps,real32) + ab_shifts(2,:)=real((/maxloc(avg_min_sep)/),real32)/real(num_steps,real32) iden=1 count1=2 denom_loop: do @@ -704,10 +709,10 @@ function get_descriptive_ab_shifts(lat,plane_up,plane_dw,bond,axis,nstore,num_st do inum=1,iden,2 count1=count1+1 if(count1.gt.nstore) exit denom_loop - ab_shifts(count1,:) = dble((/ & + ab_shifts(count1,:) = real((/ & minloc( & - abs( avg_min_sep - ( min_sep + (max_sep-min_sep)*dble(inum)/dble(iden) ) ) )& - /))/dble(num_steps) + abs( avg_min_sep - ( min_sep + (max_sep-min_sep)*real(inum,real32)/real(iden,real32) ) ) )& + /),real32)/real(num_steps,real32) end do end do denom_loop @@ -739,45 +744,58 @@ end function get_descriptive_ab_shifts !!!############################################################################# !!! generate shifts by filling missing neighours for surface atoms !!!############################################################################# - function get_shifts_DON(lat,bas,axis,intf_loc,nstore,c_scale,offset,& - bulk_DON,bulk_map,lprint,max_bondlength) result(res_shifts) - use mod_sym, only: gldfnd,confine_type - use edit_geom, only: get_bulk,wyck_spec_type,get_wyckoff - use interface_identifier, only: gen_single_DON,nstep_default,den_of_neigh_type + function get_shifts_DON(bas,axis,intf_loc,nstore,tol_sym,c_scale,offset,& + bulk_DON,bulk_map,verbose,max_bondlength) result(res_shifts) + use artemis__sym, only: gldfnd,confine_type + use artemis__geom_utils, only: get_bulk,wyck_spec_type,get_wyckoff + use artemis__interface_identifier, only: gen_single_DON,nstep_default,den_of_neigh_type implicit none + type(basis_type), intent(in) :: bas + !! Interface structure + integer, intent(in) :: axis + !! Axis of the interface + real(real32), dimension(:), intent(in) :: intf_loc + !! Location of the interfaces + integer, intent(in) :: nstore + !! Number of shifts to be generated + real(real32), intent(in) :: tol_sym + !! Tolerance for symmetry + real(real32), intent(in), optional :: c_scale + !! Scaling factor for the interface separation + real(real32), dimension(3), optional, intent(in) :: offset + !! Input offset of the two interface substructures + integer, intent(in), optional :: verbose + !! Boolean whether to print the shifts + type(bulk_DON_type), dimension(:), optional, intent(in) :: bulk_DON + !! Bulk DONs to be used for the interface + integer, dimension(:,:,:), optional, intent(in) :: bulk_map + !! Mapping of bulk atoms to the interface atoms + real(real32), intent(in), optional :: max_bondlength + !! Cutoff bondlength to consider first neighbours + + integer :: i,j,k,l,is,ia,ja,jb,jc,count1,itmp1 integer :: ntrans,iatom,nneigh,ncheck - real :: stepsize,max_sep,dist_max - real :: rtmp1,rtmp2,rtmp3 - double precision :: val,dtmp1,dtmp2 + integer :: verbose_ + real(real32) :: stepsize,max_sep,dist_max + real(real32) :: rtmp1,rtmp2,rtmp3 + real(real32) :: val,dtmp1,dtmp2 logical :: lbulk, lpresent type(confine_type) :: confine integer, dimension(2) :: plane_loc integer, dimension(3) :: ngrid,nstep,ivtmp1 - real, dimension(2) :: min_trans,lowest_atom,highest_atom - real, dimension(3) :: pos,vtmp1,vtmp2,vtmp3,gridsize,add + real(real32), dimension(2) :: min_trans,lowest_atom,highest_atom + real(real32), dimension(3) :: pos,vtmp1,vtmp2,vtmp3,gridsize,add logical, dimension(2) :: lwyckoff type(map_type), dimension(2) :: map type(wyck_spec_type), dimension(2) :: wyckoff - real, allocatable, dimension(:) :: fit_store,tmp_neigh - type(bas_type), allocatable, dimension(:) :: splitbas + real(real32), allocatable, dimension(:) :: fit_store,tmp_neigh + type(basis_type), allocatable, dimension(:) :: splitbas type(den_of_neigh_type), allocatable, dimension(:,:) :: DON_missing integer, allocatable, dimension(:,:) :: shift_store - double precision, allocatable, dimension(:,:) :: res_shifts,trans,regions - - integer, intent(in) :: axis,nstore - real, intent(in), optional :: max_bondlength - type(bas_type), intent(in) :: bas - double precision, dimension(:), intent(in) :: intf_loc - double precision, dimension(3,3), intent(in) :: lat - double precision, optional :: c_scale - logical, optional :: lprint - double precision, dimension(3), optional, intent(in) :: offset + real(real32), allocatable, dimension(:,:) :: res_shifts,trans,regions - integer, dimension(:,:,:), optional, intent(in) :: bulk_map - type(bulk_DON_type), dimension(:), optional, intent(in) :: bulk_DON - !integer :: OMP_GET_NUM_THREADS,OMP_GET_MAX_THREADS,OMP_GET_THREAD_NUM,CHUNK !integer :: nthreads @@ -785,8 +803,8 @@ function get_shifts_DON(lat,bas,axis,intf_loc,nstore,c_scale,offset,& type neighbour_type integer :: num - real :: bond - real, dimension(3) :: pos + real(real32) :: bond + real(real32), dimension(3) :: pos end type neighbour_type type(neighbour_type), allocatable, dimension(:,:) :: neighbour type intf_type @@ -796,12 +814,14 @@ function get_shifts_DON(lat,bas,axis,intf_loc,nstore,c_scale,offset,& type grid_type - real, allocatable, dimension(:) :: neigh + real(real32), allocatable, dimension(:) :: neigh end type grid_type type(grid_type), allocatable, dimension(:,:,:,:) :: course_grid + verbose_ = 0 + if(present(verbose)) verbose_ = verbose !!!----------------------------------------------------------------------------- !!! check if bulk DONs supplied !!!----------------------------------------------------------------------------- @@ -817,7 +837,7 @@ function get_shifts_DON(lat,bas,axis,intf_loc,nstore,c_scale,offset,& !!! sets up step size !!!----------------------------------------------------------------------------- allocate(res_shifts(nstore,3)) - res_shifts=0.D0 + res_shifts=0._real32 !!!----------------------------------------------------------------------------- @@ -845,9 +865,9 @@ function get_shifts_DON(lat,bas,axis,intf_loc,nstore,c_scale,offset,& !!!----------------------------------------------------------------------------- !!! determines repeated translations within the cell (reduces shift by that) !!!----------------------------------------------------------------------------- - min_trans=1.D0 + min_trans=1._real32 do i=1,2 - call gldfnd(confine,splitbas(i),splitbas(i),trans,ntrans) + call gldfnd(confine, splitbas(i), splitbas(i), trans, ntrans, tol_sym) if(ntrans.eq.0) cycle do j=1,ntrans do k=1,2 @@ -856,10 +876,10 @@ function get_shifts_DON(lat,bas,axis,intf_loc,nstore,c_scale,offset,& end do end do min_trans=abs(min_trans) - where(abs(min_trans).lt.1.D-5) - min_trans=1.D0 + where(abs(min_trans).lt.1.E-5_real32) + min_trans=1._real32 end where - if(ierror.eq.1) write(6,*) "repeated_trans:",min_trans + if(verbose_.eq.1) write(*,*) "repeated_trans:",min_trans !!!----------------------------------------------------------------------------- @@ -871,8 +891,10 @@ function get_shifts_DON(lat,bas,axis,intf_loc,nstore,c_scale,offset,& do i=1,2 wyckoff(i)=get_wyckoff(splitbas(i),axis) if(.not.allocated(wyckoff(i)%spec))then - write(6,'(1X,"Using centre atoms as bulk representation")') + write(*,'(1X,"Using centre atoms as bulk representation for parent slab", I0)') i lwyckoff(i)=.false. + else + write(*,'(1X,"Using Wyckoff atoms as bulk representation for parent slab", I0)') i end if end do else @@ -893,14 +915,14 @@ function get_shifts_DON(lat,bas,axis,intf_loc,nstore,c_scale,offset,& dist_max = 4.0 end if allocate(DON_missing(2,bas%nspec)) - if(ierror.ge.1) write(6,*) + if(verbose_.ge.1) write(*,*) region_loop: do i=1,2 - if(ierror.ge.1) write(6,'& + if(verbose_.ge.1) write(*,'& &(2X,"is",2X,"ia",4X,"nmissing",4X,"bond size (Å)",8X,"position")') count1 = 0 DON_missing(i,:) = & - gen_DON(lat,splitbas(i),dist_max,scale_dist=.false.,norm=.true.) + gen_DON(bas%lat,splitbas(i),dist_max,scale_dist=.false.,norm=.true.) !!----------------------------------------------------------------------- !! Loops through the basis and finds the missing bonds of surface atoms. !! Does this by minusing the DON of the wyckoff atom of the surface ... @@ -914,14 +936,14 @@ function get_shifts_DON(lat,bas,axis,intf_loc,nstore,c_scale,offset,& iatom = get_centre_atom(& splitbas(i),is,axis,lw=regions(i,1),up=regions(i,2)) if(iatom.eq.0)& - call err_abort("ERROR: Internal error in get_shifts_DON\n& + call err_abort("Internal error in get_shifts_DON\n& & No centre atom found in get_shifts_DON.",.true.) end if if(lbulk)then if(any(map(i)%spec(is,:splitbas(i)%spec(is)%num,:).le.0))then write(0,'("parent species atom")') write(0,'(2X,I2,6X,I2,4X,I4)') i,is,ia - call err_abort("ERROR: Internal error in get_shifts_DON\n& + call err_abort("Internal error in get_shifts_DON\n& & Mapping of bulk missing",.true.) end if end if @@ -931,8 +953,8 @@ function get_shifts_DON(lat,bas,axis,intf_loc,nstore,c_scale,offset,& !!----------------------------------------------------------------- dtmp1 = splitbas(i)%spec(is)%atom(ia,axis) - intf_loc(1) dtmp2 = splitbas(i)%spec(is)%atom(ia,axis) - intf_loc(2) - if( abs(dtmp1 - ceiling(dtmp1 - 0.5D0)) .gt. & - abs(dtmp2 - ceiling(dtmp2 - 0.5D0)))then + if( abs(dtmp1 - ceiling(dtmp1 - 0.5_real32)) .gt. & + abs(dtmp2 - ceiling(dtmp2 - 0.5_real32)))then cycle atom_loop1 end if @@ -953,10 +975,10 @@ function get_shifts_DON(lat,bas,axis,intf_loc,nstore,c_scale,offset,& DON_missing(i,is)%atom(iatom,:) - & DON_missing(i,is)%atom(ia,:) end if - !where(DON_missing(i,is)%atom(ia,:).lt.0.D0) - ! DON_missing(i,is)%atom(ia,:)=0.D0 + !where(DON_missing(i,is)%atom(ia,:).lt.0._real32) + ! DON_missing(i,is)%atom(ia,:)=0._real32 !end where - if(all(abs(DON_missing(i,is)%atom(ia,:)).lt.1.D-2))& + if(all(abs(DON_missing(i,is)%atom(ia,:)).lt.1.E-2_real32))& cycle atom_loop1 @@ -964,7 +986,7 @@ function get_shifts_DON(lat,bas,axis,intf_loc,nstore,c_scale,offset,& !! checks only 1st missing bond !!----------------------------------------------------------------- plane_loc(:)=& - get_nth_plane(invec=dble(DON_missing(i,is)%atom(ia,:)),& + get_nth_plane(invec=real(DON_missing(i,is)%atom(ia,:),real32),& nth=2,window=20,is_periodic=.false.) !! WINDOW WAS 10, NOW 20 itmp1=nint( & sum(DON_missing(i,is)%atom(ia,:plane_loc(1)))*& @@ -973,13 +995,13 @@ function get_shifts_DON(lat,bas,axis,intf_loc,nstore,c_scale,offset,& count1 = count1 +1 neighbour(i,count1)%pos = splitbas(i)%spec(is)%atom(ia,:3) !neighbour(i,count1)%pos = neighbour(i,count1)%pos - & - ! ceiling(neighbour(i,count1)%pos - 1.D0) + ! ceiling(neighbour(i,count1)%pos - 1._real32) neighbour(i,count1)%bond = & ( maxloc(DON_missing(i,is)%atom(ia,:plane_loc(1)),dim=1) & - 1 ) * dist_max/nstep_default neighbour(i,count1)%num = itmp1 - if(ierror.ge.1)& - write(6,'(2X,I2,3X,I3,7X,I2,9X,F0.3,8X,3(1X,F5.2))') & + if(verbose_.ge.1)& + write(*,'(2X,I2,3X,I3,7X,I2,9X,F0.3,8X,3(1X,F5.2))') & is,ia,& neighbour(i,count1)%num,& neighbour(i,count1)%bond,& @@ -1011,18 +1033,18 @@ function get_shifts_DON(lat,bas,axis,intf_loc,nstore,c_scale,offset,& bulk_DON(i)%spec(map(i)%spec(is,ia,1))%atom(map(i)%spec(is,ia,2),j) end do close(14) - call err_abort_print_struc(lat,splitbas(1),"lw_term.vasp",& + call err_abort_print_struc(splitbas(1),"lw_term.vasp",& + "",.false.) + call err_abort_print_struc(splitbas(2),"up_term.vasp",& "",.false.) - call err_abort_print_struc(lat,splitbas(2),"up_term.vasp",& - "",.false.) call err_abort("ERROR: Internal error in get_shifts_DON\n& & More neighbours found in slab than in bulk.",.true.) end if end do atom_loop1 end do spec_loop - if(ierror.ge.1)then - write(6,*) "nneigh:",count1 - write(6,*) + if(verbose_.ge.1)then + write(*,*) "nneigh:",count1 + write(*,*) end if if(count1.le.0)then write(0,'("WARNING: No missing bonds identified for parent slab ",I0)') i @@ -1046,9 +1068,9 @@ function get_shifts_DON(lat,bas,axis,intf_loc,nstore,c_scale,offset,& intf(2)%neigh(:)%pos(3) = intf(2)%neigh(:)%pos(3) - lowest_atom(2) lowest_atom(1) = minval(intf(1)%neigh(:)%pos(3),dim=1) highest_atom(2) = maxval(intf(2)%neigh(:)%pos(3),dim=1) - if(ierror.ge.1)then - write(6,*) "lowest atom:",lowest_atom - write(6,*) "highest atom:",highest_atom + if(abs(verbose_).ge.1)then + write(*,*) "lowest atom:",lowest_atom + write(*,*) "highest atom:",highest_atom end if @@ -1057,50 +1079,52 @@ function get_shifts_DON(lat,bas,axis,intf_loc,nstore,c_scale,offset,& !!!----------------------------------------------------------------------------- lpresent=.false. if(present(offset))then - if(offset(axis).ge.0.D0)then - max_sep = max(abs(highest_atom(2)),abs(lowest_atom(1)))*modu(lat(axis,:)) + if(offset(axis).ge.1.E-6_real32)then + max_sep = max(abs(highest_atom(2)),abs(lowest_atom(1)))*modu(bas%lat(axis,:)) lpresent=.true. end if end if if(.not.lpresent)then - max_sep = 6.0 - add = 0.D0 + max_sep = max(abs(highest_atom(2)),abs(lowest_atom(1)))*modu(bas%lat(axis,:)) + 6._real32 + add = 0._real32 end if stepsize=0.1 - ngrid(1)=nint(modu(lat(1,:))/stepsize) - ngrid(2)=nint(modu(lat(2,:))/stepsize) + ngrid(1)=nint(modu(bas%lat(1,:))/stepsize) + ngrid(2)=nint(modu(bas%lat(2,:))/stepsize) ngrid(3)=ceiling(max_sep/stepsize)+1 allocate(course_grid(2,ngrid(1),ngrid(2),ngrid(3))) allocate(tmp_neigh(max(size(intf(1)%neigh),size(intf(2)%neigh))*9)) - gridsize(1) = stepsize/modu(lat(1,:)) - gridsize(2) = stepsize/modu(lat(2,:)) - gridsize(3) = stepsize/modu(lat(3,:)) + gridsize(1) = stepsize/modu(bas%lat(1,:)) + gridsize(2) = stepsize/modu(bas%lat(2,:)) + gridsize(3) = stepsize/modu(bas%lat(3,:)) - nstep(:2) = min_trans(:2)*ngrid(:2) + nstep(:2) = nint( min_trans(:2) * ngrid(:2) ) nstep(3) = 0 do jc=1,ngrid(3) - pos(3) = dble(jc-1)*gridsize(3) + pos(3) = real(jc-1,real32)*gridsize(3) if(pos(3)+highest_atom(2).gt.(ngrid(3)-1)*gridsize(3)) exit if(pos(3)-lowest_atom(1).gt.(ngrid(3)-1)*gridsize(3)) exit nstep(3) = nstep(3) + 1 end do if(present(offset))then - if(ierror.ge.1) write(6,'(1X,"user-defined offset:",3(3X,F7.3))') offset - add = -1.0 - do i=1,3 - if(offset(i).ge.0.D0)then - nstep(i) = 1 - add(i) = offset(i) - end if - end do + if(offset(axis).ge.1.E-6_real32)then + if(verbose_.ge.1) write(*,'(1X,"user-defined offset:",3(3X,F7.3))') offset + add = -1.0 + do i=1,3 + if(offset(i).ge.0._real32)then + nstep(i) = 1 + add(i) = offset(i) + end if + end do - do i=1,3 - if(add(i).lt.0.0)then - add(i) = 0.0 - end if - end do - add(axis) = add(axis)/modu(lat(axis,:)) + do i=1,3 + if(add(i).lt.0.0)then + add(i) = 0.0 + end if + end do + add(axis) = add(axis)/modu(bas%lat(axis,:)) + end if end if !nthreads=8 @@ -1109,41 +1133,52 @@ function get_shifts_DON(lat,bas,axis,intf_loc,nstore,c_scale,offset,& !!!----------------------------------------------------------------------------- !!! Determines neighbours for each grid point !!!----------------------------------------------------------------------------- - if(ierror.ge.1)then - write(6,'(1X,A,3(2X,F8.4))') & - "lat:",modu(lat(1,:)),modu(lat(2,:)),modu(lat(3,:)) - write(6,'(1X,A,3(2X,F8.4))') "gridsize:",gridsize - write(6,*) "add:",add - write(6,*) "nstep:",nstep - write(6,*) "ngrid:",ngrid + if(abs(verbose_).ge.1)then + write(*,'(1X,A,3(2X,F8.4))') & + "lat:",modu(bas%lat(1,:)),modu(bas%lat(2,:)),modu(bas%lat(3,:)) + write(*,'(1X,A,3(2X,F8.4))') "gridsize:",gridsize + write(*,*) "add:",add + write(*,*) "nstep:",nstep + write(*,*) "ngrid:",ngrid + write(*,*) "max_sep:",max_sep + end if + + if(any(nstep(:).le.0))then + write(0,*) "nstep:",nstep + write(0,*) "ngrid:",ngrid + call err_abort_print_struc(splitbas(1),"lw_term.vasp",& + "",.false.) + call err_abort_print_struc(splitbas(2),"up_term.vasp",& + "",.false.) + call err_abort("ERROR: Internal error in get_shifts_DON",.true.) end if !$OMP PARALLEL DO & !$OMP DEFAULT(SHARED) & !$OMP PRIVATE(is,ja,jb,jc,pos,vtmp1,vtmp2,vtmp3,count1,tmp_neigh) & -!$OMP SCHEDULE(DYNAMIC,CHUNK) +!$OMP SCHEDULE(DYNAMIC,2) do k=1,2 nneigh = size(intf(k)%neigh,dim=1) do ja=1,ngrid(1) - pos(1) = dble(ja-1)*gridsize(1) + add(1) + pos(1) = real(ja-1,real32)*gridsize(1) + add(1) do jb=1,ngrid(2) - pos(2) = dble(jb-1)*gridsize(2) + add(2) + pos(2) = real(jb-1,real32)*gridsize(2) + add(2) do jc=1,ngrid(3) count1 = 0 tmp_neigh = 0 - pos(3) = dble(jc-1)*gridsize(3) + add(3) + pos(3) = real(jc-1,real32)*gridsize(3) + add(3) do is=1,nneigh vtmp1 = ( & - pos*(-1)**dble(k-1) - & - intf(k)%neigh(is)%pos(:3) )*(-1)**dble(k-1) - !vtmp1 = ( pos - intf(k)%neigh(is)%pos(:3) )!*(-1)**dble(k) + pos*(-1)**real(k-1,real32) - & + intf(k)%neigh(is)%pos(:3) )*(-1)**real(k-1,real32) + !vtmp1 = ( pos - intf(k)%neigh(is)%pos(:3) )!*(-1)**real(k,real32) vtmp2(3) = vtmp1(3) a_extend_loop: do i=-1,1,1 - vtmp2(1) = vtmp1(1) + dble(i) + vtmp2(1) = vtmp1(1) + real(i,real32) b_extend_loop: do j=-1,1,1 - vtmp2(2) = vtmp1(2) + dble(j) - vtmp3 = matmul(vtmp2,lat) + vtmp2(2) = vtmp1(2) + real(j,real32) + vtmp3 = matmul(vtmp2,bas%lat) if(modu(vtmp3).gt.dist_max) cycle b_extend_loop count1 = count1 + 1 tmp_neigh(count1) = modu(vtmp3) @@ -1168,24 +1203,24 @@ function get_shifts_DON(lat,bas,axis,intf_loc,nstore,c_scale,offset,& allocate(fit_store(nstore)) allocate(shift_store(nstore,3)) fit_store=huge(0.0) - shift_store=0.D0 + shift_store=0._real32 ! !$OMP PARALLEL DEFAULT(SHARED) NUM_NHREADS(nthreads) ! !$OMP DO PRIVATE(ja,jb,jc,pos,val,l,is,nneigh,vtmp1,ivtmp1,ncheck,rtmp1,rtmp2,val) SCHEDULE(DYNAMIC,CHUNK) do ja=1,nstep(1) - pos(1) = dble(ja-1)*gridsize(1) + pos(1) = real(ja-1,real32)*gridsize(1) b_loop1: do jb=1,nstep(2) - pos(2) = dble(jb-1)*gridsize(2) + pos(2) = real(jb-1,real32)*gridsize(2) c_loop1: do jc=1,nstep(3) - pos(3) = dble(jc-1)*gridsize(3) + pos(3) = real(jc-1,real32)*gridsize(3) - val = 0.D0 + val = 0._real32 do k=1,2 l=minval([1,2],mask=[1,2].ne.k) nneigh = size(intf(l)%neigh,dim=1) do is=1,nneigh vtmp1 = ( & - pos*(-1)**dble(l) + & - intf(l)%neigh(is)%pos )*(-1)**dble(l) + pos*(-1)**real(l,real32) + & + intf(l)%neigh(is)%pos )*(-1)**real(l,real32) vtmp1(:2) = vtmp1(:2) - floor( vtmp1(:2) ) ivtmp1 = nint(vtmp1/gridsize) ivtmp1 = ivtmp1 + 1 @@ -1247,7 +1282,7 @@ function get_shifts_DON(lat,bas,axis,intf_loc,nstore,c_scale,offset,& !!! Checks whether any shifts have been identified !!!----------------------------------------------------------------------------- if(all(shift_store.eq.0))then - call err_abort("ERROR: Internal error in get_shifts_DON\n& + call err_abort("Internal error in get_shifts_DON\n& & No shifts found.",.true.) end if @@ -1255,26 +1290,27 @@ function get_shifts_DON(lat,bas,axis,intf_loc,nstore,c_scale,offset,& !!!----------------------------------------------------------------------------- !!! Sets output of shifts !!!----------------------------------------------------------------------------- - write(6,'("Determined shifts (gridsize:",3(2X,F6.4),")")') gridsize - write(6,'(" num fit_val x y z")') - do i=1,nstore - res_shifts(i,:) = dble(shift_store(i,:))/dble(ngrid(:)-1) + if(verbose_.gt.0)then + write(*,'("Determined shifts (gridsize:",3(2X,F6.4),")")') gridsize + write(*,'(" num fit_val x y z")') + end if + do i = 1, nstore, 1 + res_shifts(i,:) = real(shift_store(i,:),real32)/real(ngrid(:)-1,real32) res_shifts(i,:2) = res_shifts(i,:2) + add(:2) - write(6,'(1X,I3,":",2X,F6.2,3(2X,I3))') i,fit_store(i),shift_store(i,:) + if(verbose_.gt.0) & + write(*,'(1X,I3,":",2X,F6.2,3(2X,I3))') i,fit_store(i),shift_store(i,:) end do - res_shifts(:,axis) = (res_shifts(:,axis)*max_sep)/modu(lat(axis,:)) + & + res_shifts(:,axis) = (res_shifts(:,axis)*max_sep)/modu(bas%lat(axis,:)) + & add(axis) - if(present(c_scale)) res_shifts(:,axis) = res_shifts(:,axis)*c_scale + if(present(c_scale)) res_shifts(:,axis) = res_shifts(:,axis) * c_scale - if(present(lprint))then - if(lprint)then - write(6,'(1X,"Shifts to be applied (Å)")') - do i=1,nstore - write(6,'(I3,":",2X,3(2X,F7.4))') & - i,res_shifts(i,:2),res_shifts(i,3)*modu(lat(axis,:)) - end do - end if + if(verbose_.gt.0)then + write(*,'(1X,"Shifts to be applied (Å)")') + do i = 1, nstore, 1 + write(*,'(I3,":",2X,3(2X,F7.4))') & + i,res_shifts(i,:2),res_shifts(i,3)*modu(bas%lat(axis,:)) + end do end if @@ -1288,10 +1324,10 @@ end function get_shifts_DON subroutine sort_shifts(fits,shifts) implicit none integer :: i,loc,num - real :: dbuff + real(real32) :: dbuff integer, dimension(3) :: ivtmp1 integer, dimension(:,:), intent(inout) :: shifts - real, dimension(:), intent(inout) :: fits + real(real32), dimension(:), intent(inout) :: fits num = size(fits,dim=1) diff --git a/src/mod_swapping.f90 b/src/fortran/lib/mod_swapping.f90 similarity index 85% rename from src/mod_swapping.f90 rename to src/fortran/lib/mod_swapping.f90 index bac183d..efd9713 100644 --- a/src/mod_swapping.f90 +++ b/src/fortran/lib/mod_swapping.f90 @@ -4,17 +4,17 @@ !!! Think Hepplestone, think HRG. !!!############################################################################# module swapping - use constants, only: ierror - use misc, only: sort1D + use artemis__constants, only: real32 + use artemis__misc, only: sort1D use misc_maths, only: gauss use misc_linalg, only: modu - use rw_geom, only: bas_type,clone_bas - use mod_sym, only: sym_setup,check_sym,sym_type,basmap_type,basis_map - use io, only: err_abort + use artemis__geom_rw, only: basis_type + use artemis__sym, only: check_sym,sym_type,basis_map_type,basis_map + use artemis__io_utils, only: err_abort implicit none - double precision :: tiny=5.0D-5 + real(real32) :: tiny=5.E-5_real32 logical :: lmirror - type(basmap_type) :: bas_map + type(basis_map_type) :: bas_map private @@ -29,34 +29,36 @@ module swapping !!! Main function to be called from ARTEMIS !!!############################################################################# function rand_swapper(lat,bas,axis,width,nswaps_per_cell,nswap,intf_loc,& - iswap,seed,sigma,require_mirror) result(bas_arr) + iswap,seed_arr,tol_sym, verbose, sigma,require_mirror) result(bas_arr) implicit none integer :: i,j,is,iout,itmp,count1 integer :: axis,nswap integer :: nabove,nbelow,nswaps_per_cell,nfail !,nperm - real :: udef_sigma,small_sigma - double precision :: dintf,dist - type(bas_type) :: tmpbas,store_bas + real(real32) :: udef_sigma,small_sigma + real(real32) :: dintf,dist + type(basis_type) :: tmpbas,store_bas type(sym_type) :: grp - !double precision, dimension(4,4) :: intf_sym + !real(real32), dimension(4,4) :: intf_sym integer, allocatable, dimension(:) :: spec_list integer, allocatable, dimension(:) :: lw_close_list,up_close_list - real, allocatable, dimension(:) :: lw_dist_list,up_dist_list - real, allocatable, dimension(:) :: lw_weight_list,up_weight_list + real(real32), allocatable, dimension(:) :: lw_dist_list,up_dist_list + real(real32), allocatable, dimension(:) :: lw_weight_list,up_weight_list integer, allocatable, dimension(:,:) :: pos_list,up_list,lw_list - double precision, allocatable, dimension(:,:) :: bas_list - double precision, dimension(4,4) :: intf_sym + real(real32), allocatable, dimension(:,:) :: bas_list + real(real32), dimension(4,4) :: intf_sym integer, intent(in) :: iswap - real, intent(in) :: width - real, optional, intent(in) :: sigma + real(real32), intent(in) :: width + real(real32), optional, intent(in) :: sigma logical, optional, intent(in) :: require_mirror - type(bas_type), intent(in) :: bas - integer, allocatable, dimension(:), intent(in) :: seed - double precision, dimension(2), intent(in) :: intf_loc !USE 1 - type(bas_type), allocatable, dimension(:) :: bas_arr - double precision, dimension(3,3), intent(in) :: lat + type(basis_type), intent(in) :: bas + integer, dimension(:), intent(in) :: seed_arr + real(real32), dimension(2), intent(in) :: intf_loc !USE 1 + type(basis_type), allocatable, dimension(:) :: bas_arr + real(real32), dimension(3,3), intent(in) :: lat + real(real32), intent(in) :: tol_sym + integer, intent(in) :: verbose !!!----------------------------------------------------------------------------- @@ -65,7 +67,7 @@ function rand_swapper(lat,bas,axis,width,nswaps_per_cell,nswap,intf_loc,& grp%nsymop = 1 nfail=50 if(present(sigma))then - if(sigma.lt.0.D0)then + if(sigma.lt.0._real32)then udef_sigma = 0.05 else udef_sigma = sigma @@ -75,7 +77,7 @@ function rand_swapper(lat,bas,axis,width,nswaps_per_cell,nswap,intf_loc,& end if udef_sigma = udef_sigma/modu(lat(axis,:)) small_sigma = 0.01/modu(lat(axis,:)) - call random_seed(put=seed) + call random_seed(put=seed_arr) !!!----------------------------------------------------------------------------- @@ -110,8 +112,8 @@ function rand_swapper(lat,bas,axis,width,nswaps_per_cell,nswap,intf_loc,& ! if(nperm.le.0) nperm=10 ! ! if(nswap.gt.nperm)then - ! write(6,'(1X,A)') "Number of possible permutations is less than requested value." - ! write(6,'(1X,A,I0)') "Resetting number of output structures to ",nperm + ! write(*,'(1X,A)') "Number of possible permutations is less than requested value." + ! write(*,'(1X,A,I0)') "Resetting number of output structures to ",nperm ! nswap=nperm ! end if !!!----------------------------------------------------------------------------- @@ -120,9 +122,9 @@ function rand_swapper(lat,bas,axis,width,nswaps_per_cell,nswap,intf_loc,& !!!----------------------------------------------------------------------------- !!! set up symmetries !!!----------------------------------------------------------------------------- - call sym_setup(grp,lat) - call clone_bas(bas,tmpbas,trans_dim=.true.) - call clone_bas(tmpbas,store_bas,trans_dim=.true.) + call grp%init(lat, tol_sym = tol_sym) + call tmpbas%copy(bas, length = 4) + call store_bas%copy(tmpbas, length = 4) !!!----------------------------------------------------------------------------- @@ -144,13 +146,13 @@ function rand_swapper(lat,bas,axis,width,nswaps_per_cell,nswap,intf_loc,& !!! NOT NEEDED? !!! To Replace with lmirror = .false. - call check_sym(grp,tmpbas,lsave=.true.) - intf_sym_loop: do i=1,grp%nsymop + call check_sym(grp,tmpbas,lsave=.true., tol_sym=tol_sym) + intf_sym_loop: do i = 1, grp%nsymop !if(symops(i).eq.1) cycle intf_sym_loop - if(abs(grp%sym(i,4,axis)).lt.tiny) cycle intf_sym_loop - if(abs(grp%sym(i,axis,axis)+1.D0).gt.tiny) cycle intf_sym_loop - intf_sym(1:4,1:4) = grp%sym(i,1:4,1:4) - bas_map = basis_map(intf_sym,tmpbas) + if(abs(grp%sym(4,axis,i)).lt.tiny) cycle intf_sym_loop + if(abs(grp%sym(axis,axis,i)+1._real32).gt.tiny) cycle intf_sym_loop + intf_sym(1:4,1:4) = grp%sym(1:4,1:4,i) + bas_map = basis_map(intf_sym,tmpbas, tol_sym=tol_sym) lmirror = .true. exit intf_sym_loop end do intf_sym_loop @@ -165,10 +167,10 @@ & Error in rand_swapper subroutine in mod_swapper.f90\n& &Exiting...",fmtd=.true.) end if end do - if(ierror.ge.1)then - write(6,*) "mirror found for swaps" - write(6,'(4(2X,F9.4))') intf_sym(:,:) - write(6,*) + if(verbose.ge.1)then + write(*,*) "mirror found for swaps" + write(*,'(4(2X,F9.4))') intf_sym(:,:) + write(*,*) end if else write(0,*) "WARNING: No mirror identified in interface" @@ -184,8 +186,8 @@ & Error in rand_swapper subroutine in mod_swapper.f90\n& end if 10 deallocate(grp%sym) - call sym_setup(grp,lat,new_start=.true.) - call check_sym(grp,tmpbas)!,lsave=.true.) + call grp%init(lat,new_start=.true., tol_sym = tol_sym) + call check_sym(grp,tmpbas, tol_sym=tol_sym)!,lsave=.true.) dintf=intf_loc(1) @@ -206,8 +208,8 @@ & Error in rand_swapper subroutine in mod_swapper.f90\n& nabove = size(up_close_list) end select if(nswaps_per_cell.gt.min(nabove,nbelow))then - write(6,'(1X,A)') "Number of possible swaps is less than requested value." - write(6,'(1X,A,I0)') "Resetting number of swaps to ",min(nabove,nbelow) + write(*,'(1X,A)') "Number of possible swaps is less than requested value." + write(*,'(1X,A,I0)') "Resetting number of swaps to ",min(nabove,nbelow) nswaps_per_cell=min(nabove,nbelow) end if @@ -226,7 +228,9 @@ & Error in rand_swapper subroutine in mod_swapper.f90\n& lw_list,up_list,& lw_dist_list,up_dist_list,& lw_close_list,up_close_list,& - lw_weight_list,up_weight_list) + lw_weight_list,up_weight_list, & + verbose=verbose & + ) end select bas_arr(1) = tmpbas iout = 1 @@ -248,13 +252,15 @@ & Error in rand_swapper subroutine in mod_swapper.f90\n& lw_list,up_list,& lw_dist_list,up_dist_list,& lw_close_list,up_close_list,& - lw_weight_list,up_weight_list) + lw_weight_list,up_weight_list, & + verbose=verbose & + ) end select - !call check_sym(tmpbas,itmp) + !call check_sym(tmpbas,itmp,tol_sym=tol_sym) !call loadbar(iout,10) do j=1,iout - call check_sym(grp,bas1=tmpbas,tmpbas2=bas_arr(j))!,itmp,bas_arr(j)) + call check_sym(grp,basis=tmpbas,tmpbas2=bas_arr(j),tol_sym=tol_sym)!,itmp,bas_arr(j)) if(grp%nsymop.ne.0) cycle symloop end do @@ -285,18 +291,18 @@ subroutine check_intf(lat,bas,dintf,width,lw_list,up_list,nbelow,nabove,bas_list implicit none integer :: i,itmp1,itmp2 integer :: nbelow,nabove,axis - double precision :: dintf,width - type(bas_type) :: bas - double precision, dimension(3,3) :: lat - double precision, dimension(:,:) :: bas_list + real(real32) :: dintf,width + type(basis_type) :: bas + real(real32), dimension(3,3) :: lat + real(real32), dimension(:,:) :: bas_list integer, allocatable, dimension(:,:) :: lw_list,up_list,pos_list nbelow=count(dintf-bas_list(:,axis).le.width.and.dintf-bas_list(:,axis).ge.0) nabove=count(bas_list(:,axis)-dintf.le.width.and.bas_list(:,axis)-dintf.gt.0) if(min(nabove,nbelow).eq.0)then - write(6,'(1X,"No atoms found within ",F0.2," Å of the interface.")') width*modu(lat(axis,:)) - write(6,'(1X,"Exiting code...")') + write(*,'(1X,"No atoms found within ",F0.2," Å of the interface.")') width*modu(lat(axis,:)) + write(*,'(1X,"Exiting code...")') call exit() end if @@ -332,9 +338,9 @@ subroutine rand_swap(bas,swap_bas,nabove,nbelow,nswaps_per_cell,up_list,lw_list) integer :: itmp1,itmp2,old_itmp1 integer :: lw_mirror,up_mirror integer :: lw_remove,up_remove,nabove,nbelow,nswaps_per_cell - real :: r_rand + real(real32) :: r_rand integer, allocatable, dimension(:,:) :: swap_list,up_list,lw_list - type(bas_type) :: bas,swap_bas + type(basis_type) :: bas,swap_bas !!!----------------------------------------------------------------------------- !!! randomly select atoms above and below the interface @@ -432,21 +438,21 @@ subroutine check_intf_depth(lat,bas,axis,intf_loc,sigma,& implicit none integer :: i,is,ia integer :: nbelow,nabove - real :: rtol - double precision, dimension(2) :: midpoint + real(real32) :: rtol + real(real32), dimension(2) :: midpoint integer, allocatable, dimension(:) :: tmp_list1,tmp_list2 - real, allocatable, dimension(:) :: tmp_dist_list1,tmp_dist_list2 + real(real32), allocatable, dimension(:) :: tmp_dist_list1,tmp_dist_list2 integer, intent(in) :: axis - real, intent(in) :: sigma - type(bas_type), intent(in) :: bas - double precision, dimension(2), intent(in) :: intf_loc - double precision, dimension(3,3), intent(in) :: lat + real(real32), intent(in) :: sigma + type(basis_type), intent(in) :: bas + real(real32), dimension(2), intent(in) :: intf_loc + real(real32), dimension(3,3), intent(in) :: lat integer, allocatable, dimension(:), intent(out) :: spec_list integer, allocatable, dimension(:), intent(out) :: lw_close_list,up_close_list - real, allocatable, dimension(:), intent(out) :: lw_dist_list,up_dist_list - real, allocatable, dimension(:), intent(out) :: lw_weight_list,up_weight_list + real(real32), allocatable, dimension(:), intent(out) :: lw_dist_list,up_dist_list + real(real32), allocatable, dimension(:), intent(out) :: lw_weight_list,up_weight_list integer, allocatable, dimension(:,:), intent(out) :: lw_list,up_list @@ -456,12 +462,12 @@ subroutine check_intf_depth(lat,bas,axis,intf_loc,sigma,& rtol = 0.1/modu(lat(axis,:)) midpoint(1) = (intf_loc(1) + intf_loc(2))/2 - midpoint(2) = (1.D0 + intf_loc(1) + intf_loc(2))/2 + midpoint(2) = (1._real32 + intf_loc(1) + intf_loc(2))/2 if(midpoint(1).lt.intf_loc(1)) & - midpoint(1) = midpoint(1) + 1.D0 + midpoint(1) = midpoint(1) + 1._real32 if(midpoint(2).gt.intf_loc(1)) & - midpoint(2) = midpoint(2) - 1.D0 + midpoint(2) = midpoint(2) - 1._real32 !!!----------------------------------------------------------------------------- @@ -540,11 +546,11 @@ subroutine check_intf_depth(lat,bas,axis,intf_loc,sigma,& !!!----------------------------------------------------------------------------- allocate(lw_weight_list(nbelow)) allocate(lw_close_list(nbelow)) - lw_weight_list(1) = gauss(pos=lw_dist_list(1),centre=0.0,sigma=sigma) + lw_weight_list(1) = gauss(pos=lw_dist_list(1),centre=0._real32,sigma=sigma) lw_close_list(1) = count(abs(lw_dist_list(1) - lw_dist_list(:nbelow)).le.rtol) do i=2,nbelow - lw_weight_list(i) = lw_weight_list(i-1) + gauss(pos=lw_dist_list(i),centre=0.0,sigma=sigma) + lw_weight_list(i) = lw_weight_list(i-1) + gauss(pos=lw_dist_list(i),centre=0._real32,sigma=sigma) lw_close_list(i) = count(abs(lw_dist_list(i) - lw_dist_list(:nbelow)).le.rtol) end do @@ -552,11 +558,11 @@ subroutine check_intf_depth(lat,bas,axis,intf_loc,sigma,& allocate(up_weight_list(nabove)) allocate(up_close_list(nabove)) - up_weight_list(1) = gauss(pos=up_dist_list(1),centre=0.0,sigma=sigma) + up_weight_list(1) = gauss(pos=up_dist_list(1),centre=0._real32,sigma=sigma) up_close_list(1) = count(abs(up_dist_list(1) - up_dist_list(:nabove)).le.rtol) do i=2,nabove - up_weight_list(i) = up_weight_list(i-1) + gauss(pos=up_dist_list(i),centre=0.0,sigma=sigma) + up_weight_list(i) = up_weight_list(i-1) + gauss(pos=up_dist_list(i),centre=0._real32,sigma=sigma) up_close_list(i) = count(abs(up_dist_list(i) - up_dist_list(:nabove)).le.rtol) end do @@ -577,26 +583,29 @@ subroutine rand_swap_depth(bas,swap_bas,& lw_list,up_list,& lw_dist_list,up_dist_list,& lw_close_list,up_close_list,& - lw_weight_list,up_weight_list) + lw_weight_list,up_weight_list, & + verbose & + ) implicit none integer :: i,loc1,loc2 integer :: nbelow,nabove integer :: lw_mirror,up_mirror - real :: r_rand1,r_rand2 + real(real32) :: r_rand1,r_rand2 integer, allocatable, dimension(:) :: lw_convert,up_convert integer, allocatable, dimension(:,:) :: swap_list - real, allocatable, dimension(:) :: tlw_weight_list,tup_weight_list + real(real32), allocatable, dimension(:) :: tlw_weight_list,tup_weight_list integer, dimension(:), intent(in) :: spec_list integer, dimension(:), intent(in) :: lw_close_list,up_close_list - real, dimension(:), intent(in) :: lw_dist_list,up_dist_list - real, dimension(:), intent(in) :: lw_weight_list,up_weight_list + real(real32), dimension(:), intent(in) :: lw_dist_list,up_dist_list + real(real32), dimension(:), intent(in) :: lw_weight_list,up_weight_list integer, dimension(:,:), intent(in) :: lw_list,up_list - real, intent(in) :: sigma,small_sigma - type(bas_type), intent(inout) :: swap_bas + real(real32), intent(in) :: sigma,small_sigma + type(basis_type), intent(inout) :: swap_bas integer, intent(in) :: nswaps_per_cell - type(bas_type), intent(in) :: bas + type(basis_type), intent(in) :: bas + integer, intent(in) :: verbose ! make a list of natoms long, with each location pointing to a specific atomic species and number @@ -708,9 +717,9 @@ subroutine rand_swap_depth(bas,swap_bas,& swap_list(:i,2),& sigma,small_sigma) - if(ierror.ge.1) & + if(verbose.ge.1) & write(0,'(& - I0,"th swap is ",I0,& + &I0,"th swap is ",I0,& &" with ",I0," at distances ",F7.3," and ",F7.3)') & i,swap_list(i,:),& lw_dist_list(swap_list(i,1)),up_dist_list(swap_list(i,2)) @@ -763,12 +772,12 @@ function recalc_rand_distrib(dist_list,conversion,close_list,swap_list,sigma,sma implicit none integer :: i,j integer :: nswaps,num - real :: small_sigma + real(real32) :: small_sigma - real, intent(in) :: sigma + real(real32), intent(in) :: sigma integer, dimension(:),intent(in) :: close_list,swap_list,conversion - real, dimension(:),intent(in) :: dist_list - real, allocatable, dimension(:) :: new_list + real(real32), dimension(:),intent(in) :: dist_list + real(real32), allocatable, dimension(:) :: new_list num = size(conversion) @@ -777,7 +786,7 @@ function recalc_rand_distrib(dist_list,conversion,close_list,swap_list,sigma,sma allocate(new_list(num)) do i=1,num - new_list(i) = gauss(pos=dist_list(conversion(i)),centre=0.0,sigma=sigma) + new_list(i) = gauss(pos=dist_list(conversion(i)),centre=0._real32,sigma=sigma) do j=1,nswaps diff --git a/src/fortran/lib/mod_sym.f90 b/src/fortran/lib/mod_sym.f90 new file mode 100644 index 0000000..938dfcc --- /dev/null +++ b/src/fortran/lib/mod_sym.f90 @@ -0,0 +1,1531 @@ +!!!############################################################################# +!!! Code written by Ned Thaddeus Taylor and Francis Huw Davies +!!! Code part of the ARTEMIS group (Hepplestone research group). +!!! Think Hepplestone, think HRG. +!!!############################################################################# +!!!module contains symmetry-related functions and subroutines. +!!!module includes the following functions and subroutines: +!!! check_sym (checks supplied symmetries against supplied basis or ... +!!! ... checks whether the two supplied bases match after ... +!!! ... applying symmetries) +!!! gldfnd (output translations that maps two bases) +!!! mksym (makes array of symmetries that apply to supplied lattice +!!! basis_map (finds symmetry equivalent atoms in two bases based on ... +!!! ... the supplied transformation matrix) +!!!############################################################################# +module artemis__sym + use artemis__constants, only: real32, pi + use misc_linalg, only: modu, inverse_3x3, det, uvec + use artemis__geom_rw, only: basis_type + implicit none + + + private + + + public :: tol_sym_default + public :: sym_type + public :: check_sym, gldfnd + + public :: confine_type + + public :: basis_map_type, basis_map + + + + real(real32) :: tol_sym_default = 1.E-6_real32 + integer, allocatable, dimension(:) :: symops_compare + + interface get_wyckoff_atoms + procedure get_wyckoff_atoms_any,get_wyckoff_atoms_loc + end interface get_wyckoff_atoms + + + type spec_wyck_type + integer :: num + character(len=5) :: name + integer, allocatable, dimension(:) :: atom + end type spec_wyck_type + type wyck_type + integer :: nwyck + type(spec_wyck_type), allocatable, dimension(:) :: spec + end type wyck_type + + + type spcmap_type + integer, allocatable ,dimension(:) :: atom + end type spcmap_type + type basis_map_type + type(spcmap_type), allocatable, dimension(:) :: spec + end type basis_map_type + + type confine_type + !! apply any confinement/constraints on symmetries + logical :: l=.false. + !! axis to confine + integer :: axis=0 + !! states whether to consider mirrors in only one plane + logical :: lmirror=.false. + !! if l=.false. -> laxis defines which axes are free + !! if l=.true. -> laxis defines which axes are confined + logical, dimension(3) :: laxis=(/.false.,.false.,.false./) + end type confine_type + + type sym_type + integer :: nsym = 0 + integer :: nlatsym = 0 + integer :: nsymop = 0 + integer :: npntop = 0 + logical :: lspace = .true. + logical :: lmolec = .false. + integer :: start_idx = 1, end_idx =0 + integer, allocatable, dimension(:) :: op + real(real32), allocatable, dimension(:,:,:) :: sym + type(confine_type) :: confine + real(real32), allocatable, dimension(:,:,:) :: sym_save + contains + procedure, pass(this) :: init => initialise_sym_type + procedure, pass(this) :: copy => copy_sym_type + end type sym_type + + + + +contains + +!############################################################################### + subroutine initialise_sym_type(this,lat,predefined,new_start,tol_sym) + !! Initialises the symmetry container + implicit none + + ! Arguments + class(sym_type), intent(inout) :: this + real(real32), dimension(3,3), intent(in) :: lat + logical, optional, intent(in) :: predefined + logical, optional, intent(in) :: new_start + real(real32), optional, intent(in) :: tol_sym + + + real(real32) :: tol_sym_ + logical :: predefined_, new_start_ + + + tol_sym_ = tol_sym_default + if(present(tol_sym)) tol_sym_ = tol_sym + if(present(new_start))then + if(new_start)then + if(allocated(this%op)) deallocate(this%op) + if(allocated(this%sym)) deallocate(this%sym) + end if + end if + + predefined_ = .true. + if(present(predefined)) predefined_ = predefined + if(predefined_)then + call gen_fundam_sym_matrices(this, lat, tol_sym_) + else + call mksym(this, lat, tol_sym_) + end if + + if(allocated(symops_compare)) deallocate(symops_compare) + this%nsymop=0 + + new_start_ = .true. + if(present(new_start)) new_start_ = new_start + if(new_start_.or.this%end_idx.eq.0)then + this%end_idx = this%nsym + end if + + end subroutine initialise_sym_type +!############################################################################### + + +!############################################################################### + subroutine copy_sym_type(this, source) + !! Copy symmetry container + implicit none + + ! Arguments + class(sym_type), intent(inout) :: this + !! Destination symmetry group + type(sym_type), intent(in) :: source + !! Source symmetry group + + + if(allocated(this%op)) deallocate(this%op) + if(allocated(this%sym)) deallocate(this%sym) + if(allocated(this%sym_save)) deallocate(this%sym_save) + + this%nsym = source%nsym + this%nlatsym = source%nlatsym + this%nsymop = source%nsymop + this%npntop = source%npntop + this%lspace = source%lspace + this%lmolec = source%lmolec + this%start_idx = source%start_idx + this%end_idx = source%end_idx + this%confine = source%confine + + if(allocated(source%op)) & + allocate(this%op, source = source%op) + if(allocated(source%sym)) & + allocate(this%sym, source = source%sym) + if(allocated(source%sym_save)) & + allocate(this%sym_save, source = source%sym_save) + + end subroutine copy_sym_type +!############################################################################### + + +!!!############################################################################# +!!! builds an array of the symmetries that apply to the supplied lattice +!!!############################################################################# +!!! tfbas : transformed basis +!!!############################################################################# + subroutine check_sym( & + grp, basis, iperm, tmpbas2, wyckoff, lsave, lat, loc, check_all_sym, & + verbose, tol_sym & + ) + implicit none + type(basis_type), intent(in) :: basis + type(sym_type), intent(inout) :: grp + + integer, optional, intent(in) :: iperm + logical, optional, intent(in) :: lsave,check_all_sym + type(basis_type), optional, intent(in) :: tmpbas2 + type(wyck_type), optional, intent(inout) :: wyckoff + real(real32), dimension(3), optional, intent(in) :: loc + real(real32), dimension(3,3), optional, intent(in) :: lat + integer, optional, intent(in) :: verbose + real(real32), optional, intent(in) :: tol_sym + + integer :: i,j,k,iatom,jatom,ispec,itmp1 + integer :: is,isym,jsym,count,ntrans + integer :: samecount,oldnpntop + logical :: lsave_,lwyckoff,ltransformed, is_a_symmetry + integer :: verbose_ + logical :: check_all_sym_ + real(real32) :: tol_sym_ + type(basis_type) :: basis2, tfbas + real(real32), dimension(3) :: diff + real(real32), dimension(3,3) :: ident + type(wyck_type), allocatable, dimension(:) :: wyck_check + real(real32), allocatable, dimension(:,:) :: trans + real(real32), allocatable, dimension(:,:,:) :: tmpsav + + + verbose_ = 0 + tol_sym_ = tol_sym_default + if(present(verbose)) verbose_ = verbose + if(present(tol_sym)) tol_sym_ = tol_sym +204 format(4(F11.6),/,4(F11.6),/,4(F11.6),/,4(F11.6)) + + ! check length of basis + do is = 1, basis%nspec + if(size(basis%spec(is)%atom,2).ne.4)then + write(0,'("ERROR: error encountered in check_sym")') + write(0,'(2X,"Internal error in subroutine check_sym in artemis__sym.f90")') + write(0,'(2X,"size of basis is not 4")') + return + end if + end do + + +!!!----------------------------------------------------------------------------- +!!! allocated grp%op +!!!----------------------------------------------------------------------------- + if(allocated(grp%op)) deallocate(grp%op) + allocate(grp%op(grp%nsym*minval(basis%spec(:)%num))) + grp%op = 0 + + if(present(lsave))then + lsave_ = lsave + else + lsave_ = .false. + end if + + +!!!----------------------------------------------------------------------------- +!!! checks for optional arguments and assigns values if not present +!!!----------------------------------------------------------------------------- + check_all_sym_ = .true. + if(present(tmpbas2)) then + call basis2%copy(tmpbas2) + if(present(check_all_sym)) check_all_sym_ = check_all_sym + else + call basis2%copy(basis) + end if + allocate(tmpsav(4,4,grp%nsym*minval(basis%spec(:)%num))) + itmp1 = maxval(basis%spec(:)%num) + + +!!!----------------------------------------------------------------------------- +!!! initialises variables +!!!----------------------------------------------------------------------------- + allocate(trans(minval(basis%spec(:)%num+2),3)); trans = 0._real32 + allocate(tfbas%spec(basis%nspec)) + itmp1 = size(basis%spec(1)%atom(1,:),dim=1) + do is=1,basis%nspec + allocate(tfbas%spec(is)%atom(basis%spec(is)%num,itmp1)) + end do + grp%nsymop = 0 + grp%npntop = 0 + + +!!!----------------------------------------------------------------------------- +!!! if present, initialises wyckoff arrays +!!!----------------------------------------------------------------------------- + allocate(wyck_check(grp%nsym*minval(basis%spec(:)%num))) + do isym=1,grp%nsym*minval(basis%spec(:)%num) + allocate(wyck_check(isym)%spec(basis%nspec)) + do ispec=1,basis%nspec + allocate(wyck_check(isym)%spec(ispec)%atom(basis%spec(ispec)%num)) + wyck_check(isym)%spec(ispec)%atom = 0 + end do + end do + if(present(wyckoff))then + lwyckoff = .true. + if(allocated(wyckoff%spec)) deallocate(wyckoff%spec) + wyckoff%nwyck = 0 + allocate(wyckoff%spec(basis%nspec)) + do ispec=1,basis%nspec + wyckoff%spec(ispec)%num = 0 + wyckoff%spec(ispec)%name = "" + allocate(wyckoff%spec(ispec)%atom(basis%spec(ispec)%num)) + do iatom=1,basis%spec(ispec)%num + wyckoff%spec(ispec)%atom(iatom) = iatom + end do + end do + else + lwyckoff = .false. + end if + + +!!!----------------------------------------------------------------------------- +!!! set up identity matrix as reference +!!!----------------------------------------------------------------------------- + ltransformed = .false. + ident = 0._real32 + do i=1,3 + ident(i,i) = 1._real32 + end do + + +!!!----------------------------------------------------------------------------- +!!! applying symmetries to basis to see if the basis conforms to any of them +!!!----------------------------------------------------------------------------- + itmp1 = 1 + symloop: do isym = grp%start_idx, grp%end_idx, 1 + if(verbose_.eq.2.or.verbose_.eq.3) write(*,204) & + grp%sym(1:4,1:4,isym) + !------------------------------------------------------------------------ + ! apply symmetry operator to basis + !------------------------------------------------------------------------ + do ispec = 1, basis%nspec, 1 + do iatom = 1, basis%spec(ispec)%num, 1 + tfbas%spec(ispec)%atom(iatom,1:3) = & + matmul(basis%spec(ispec)%atom(iatom,1:4),grp%sym(1:4,1:3,isym)) + do j=1,3 + tfbas%spec(ispec)%atom(iatom,j) = & + tfbas%spec(ispec)%atom(iatom,j) - & + ceiling(tfbas%spec(ispec)%atom(iatom,j)-0.5_real32) + end do + end do + end do + !------------------------------------------------------------------------ + ! check whether transformed basis matches original basis + !------------------------------------------------------------------------ + count=0 + is_a_symmetry = .true. + spcheck: do ispec = 1, basis%nspec, 1 + diff = 0._real32 + samecount = 0 + wyck_check(itmp1)%spec(ispec)%atom = 0 + atmcheck: do iatom = 1, basis%spec(ispec)%num, 1 + atmcyc: do jatom = 1, basis%spec(ispec)%num, 1 + !if(wyck_check(itmp1)%spec(ispec)%atom(jatom).ne.0) cycle atmcyc + diff = tfbas%spec(ispec)%atom(iatom,1:3) - & + basis2%spec(ispec)%atom(jatom,1:3) + diff(:) = diff(:) - floor(diff(:)) + where(abs(diff(:)-1._real32).lt.tol_sym_) + diff(:)=0._real32 + end where + if(sqrt(dot_product(diff,diff)).lt.tol_sym_)then + samecount = samecount + 1 + wyck_check(itmp1)%spec(ispec)%atom(iatom) = jatom + end if + if((iatom.eq.basis%spec(ispec)%num).and.& + (jatom.eq.basis%spec(ispec)%num))then + if (samecount.ne.basis%spec(ispec)%num)then + is_a_symmetry = .false. + exit spcheck + end if + end if + end do atmcyc + count = count + samecount + end do atmcheck + if(samecount.ne.basis%spec(ispec)%num)then + is_a_symmetry = .false. + exit spcheck + end if + end do spcheck + if(is_a_symmetry)then + grp%npntop = grp%npntop + 1 + grp%nsymop = grp%nsymop + 1 + itmp1 = grp%nsymop + 1 + tmpsav(:,:,grp%nsymop) = grp%sym(:,:,isym) + grp%op(grp%nsymop) = isym + if(grp%nsymop.ne.0.and..not.check_all_sym_) exit symloop + end if + trans = 0._real32 + ntrans = 0 + !------------------------------------------------------------------------ + ! checks if translations are valid with the current symmetry operation + !------------------------------------------------------------------------ + if(grp%lspace) then + if(all(abs(grp%sym(1:3,1:3,isym)-ident).lt.tol_sym_))then + ltransformed=.false. + else + ltransformed=.true. + end if + call gldfnd(grp%confine,& + basis2,tfbas,& + trans,ntrans,& + tol_sym_,& + transformed=ltransformed,& + wyck_check=wyck_check(itmp1:)) + if(ntrans.gt.0) then + if(.not.check_all_sym_.and..not.lsave_)then + grp%nsymop = grp%nsymop + 1 + exit symloop + end if + transloop: do i = 1, ntrans, 1 + if(dot_product(trans(i,:),trans(i,:)).lt.tol_sym_) & + cycle transloop + if(verbose_.eq.3) write(*,*) trans(i,:) + if(isym.ne.1)then + do jsym=2,grp%nsymop + if(grp%op(jsym).eq.1) then + if(all(abs(trans(i,1:3)-tmpsav(4,1:3,jsym)).lt.& + tol_sym_)) cycle transloop + diff = trans(i,1:3) - tmpsav(4,1:3,jsym) + diff = diff - ceiling( diff - 0.5_real32 ) + do k=1,i + if(all(abs(diff-trans(k,1:3)).lt.tol_sym_)) & + cycle transloop + end do + end if + end do + end if + grp%nsymop = grp%nsymop + 1 + itmp1 = grp%nsymop + 1 + tmpsav(:,:,grp%nsymop) = grp%sym(:,:,isym) + tmpsav(4,1:3,grp%nsymop) = trans(i,:) + grp%op(grp%nsymop) = isym + end do transloop + if(.not.check_all_sym_) exit symloop + end if + end if + oldnpntop = grp%npntop + end do symloop + + +!!!----------------------------------------------------------------------------- +!!! allocates and saves the array sym_save if the first time submitted +!!!----------------------------------------------------------------------------- + if(lsave_)then + if(allocated(grp%sym_save)) deallocate(grp%sym_save) + allocate(grp%sym_save(4,4,grp%nsymop)) + grp%sym_save=0._real32 + grp%sym_save(:,:,:grp%nsymop) = tmpsav(:,:,:grp%nsymop) + grp%sym_save(4,4,:) = 1._real32 + deallocate(tmpsav) + end if + + + iperm_if: if(present(iperm))then + select case(iperm) + case(-1) + return + case(0) + exit iperm_if + case default + if(.not.allocated(symops_compare))then + write(0,'("ERROR: Internal error in check_sym")') + write(0,'(2X,"check_sym in artemis__sym.f90 is trying to assign a & + &value to symops_compare, which hasn''t been allocated")') + exit iperm_if + end if + symops_compare(iperm)=grp%nsymop + end select + end if iperm_if + + + if(lsave_)then + deallocate(grp%sym) + call move_alloc(grp%sym_save, grp%sym) + grp%nsym = grp%nsymop + end if + + +!!!----------------------------------------------------------------------------- +!!! if wyckoff present, set up wyckoff atoms +!!!----------------------------------------------------------------------------- + if(lwyckoff)then + if(present(lat).and.present(loc))then + wyckoff=get_wyckoff_atoms(wyck_check(:grp%nsymop),lat,basis,loc) + else + wyckoff=get_wyckoff_atoms(wyck_check(:grp%nsymop)) + end if + end if + + end subroutine check_sym +!!!############################################################################# + + +!!!############################################################################# +!!! supplies the glides (if any) that are required to match the two bases ... +!!! ... "basis1" and "basis2" onto one another +!!!############################################################################# + subroutine gldfnd( & + confine, basis1, basis2, & + trans, ntrans, & + tol_sym, & + transformed, wyck_check & + ) + implicit none + type(confine_type), intent(in) :: confine + type(basis_type), intent(in) :: basis1,basis2 + real(real32), dimension(:,:), intent(out) :: trans + integer, intent(out) :: ntrans + real(real32), intent(in) :: tol_sym + + logical, optional, intent(in) :: transformed + + type(wyck_type), dimension(:), optional, intent(inout) :: wyck_check + + integer :: i,j,ispec,iatom,jatom,katom,itmp1 + integer :: minspecloc,samecount + logical :: lwyckoff + real(real32), dimension(3) :: ttrans,tmpbas,diff + real(real32), allocatable, dimension(:,:) :: sav_trans + + + +!!!----------------------------------------------------------------------------- +!!! Allocate arrays and initialise variables +!!!----------------------------------------------------------------------------- + ttrans=0._real32 + trans=0._real32 + samecount=0 + ntrans=0 + minspecloc=minloc(basis1%spec(:)%num,mask=basis1%spec(:)%num.ne.0,dim=1) + + if(present(transformed))then + if(.not.transformed)then + if(basis1%spec(minspecloc)%num.eq.1) return + end if + else + if(basis1%spec(minspecloc)%num.eq.1) return + end if + allocate(sav_trans(basis1%natom,3)) + + +!!!----------------------------------------------------------------------------- +!!! if present, initialises tmp_wyckoff arrays +!!!----------------------------------------------------------------------------- + if(present(wyck_check))then + lwyckoff=.true. + else + lwyckoff=.false. + end if + + +!!!----------------------------------------------------------------------------- +!!! Cycles through each atom in transformed basis and finds translation ... +!!! ... vector that maps it back onto the 1st atom in the original, ... +!!! ... untransformed, basis. +!!! Then tests this translation vector on all other atoms to see if it works ... +!!! ... as a translation vector for the symmetry. +!!!----------------------------------------------------------------------------- + trloop: do iatom = 1, basis1%spec(minspecloc)%num + ttrans(:) = 0._real32 + ttrans(1:3) = basis1%spec(minspecloc)%atom(1,1:3)-& + basis2%spec(minspecloc)%atom(iatom,1:3) + if(all(abs(ttrans(1:3)-anint(ttrans(1:3))).lt.tol_sym)) cycle trloop + if(confine%l)then + if(confine%laxis(confine%axis).and.& + abs(ttrans(confine%axis)-nint(ttrans(confine%axis)))& + .gt.tol_sym) cycle trloop + end if + itmp1 = 0 + sav_trans = 0._real32 + if(lwyckoff.and.ntrans+1.gt.size(wyck_check))then + write(0,'("ERROR: error encountered in gldfnd")') + write(0,'(2X,"Internal error in subroutine gldfnd in artemis__sym.f90")') + write(0,'(2X,"ntrans is greater than wyck_check")') + write(0,'(2X,"EXITING SUBROUTINE")') + return + end if + trcyc: do ispec = 1, basis1%nspec + samecount=0 + if(lwyckoff) wyck_check(ntrans+1)%spec(ispec)%atom(:) = 0 + atmcyc2: do jatom=1,basis1%spec(ispec)%num + itmp1 = itmp1 + 1 + tmpbas(1:3) = basis2%spec(ispec)%atom(jatom,1:3) + ttrans(1:3) + tmpbas(:) = tmpbas(:) - ceiling(tmpbas(:)-0.5_real32) + atmcyc3: do katom=1,basis1%spec(ispec)%num + !if(lwyckoff.and.& + ! wyck_check(ntrans+1)%spec(ispec)%atom(katom).ne.0) & + ! cycle atmcyc3 + diff = tmpbas(1:3) - basis1%spec(ispec)%atom(katom,1:3) + do j=1,3 + diff(j) = mod((diff(j)+100._real32),1.0) + if((abs(diff(j)-1._real32)).lt.(tol_sym)) diff(j) = 0._real32 + end do + if(sqrt(dot_product(diff,diff)).lt.tol_sym)then + samecount = samecount + 1 + sav_trans(itmp1,:) = basis1%spec(ispec)%atom(katom,1:3) - & + basis2%spec(ispec)%atom(jatom,1:3) + sav_trans(itmp1,:) = sav_trans(itmp1,:) - & + ceiling(sav_trans(itmp1,:)-0.5_real32) + if(lwyckoff) & + wyck_check(ntrans+1)%spec(ispec)%atom(jatom) = katom + cycle atmcyc2 + end if + end do atmcyc3 + !cycle trloop + end do atmcyc2 + if (samecount.ne.basis1%spec(ispec)%num) cycle trloop + end do trcyc +!!!----------------------------------------------------------------------------- +!!! Cleans up succeeded translation vector +!!!----------------------------------------------------------------------------- + do j = 1, 3 + itmp1 = maxloc(abs(sav_trans(:,j)),dim=1) + ttrans(j) = sav_trans(itmp1,j) + ttrans(j) = ttrans(j) - ceiling(ttrans(j)-0.5_real32) + end do +!!!----------------------------------------------------------------------------- +!!! If axis is confined, removes all symmetries not confined to the axis plane +!!!----------------------------------------------------------------------------- + if(confine%l)then + if(confine%laxis(confine%axis).and.& + abs(ttrans(confine%axis)-nint(ttrans(confine%axis)))& + .gt.tol_sym) cycle trloop + else + do i = 1, 3 + if(confine%laxis(i))then + if(abs(ttrans(confine%axis)-floor(ttrans(confine%axis)))& + .lt.tol_sym) cycle trloop + end if + end do + end if +!!!----------------------------------------------------------------------------- +!!! Checks whether this translation has already been saved +!!!----------------------------------------------------------------------------- + do i = 1, ntrans + if(all(abs(ttrans(:)-trans(i,:)).lt.tol_sym)) cycle trloop + end do + ntrans = ntrans + 1 + trans(ntrans,1:3) = ttrans(1:3) + if(confine%l) return + end do trloop + + + return + end subroutine gldfnd +!!!############################################################################# + + +!############################################################################### + subroutine gen_fundam_sym_matrices(grp, lat, tol_sym) + !! Generate fundamental symmetry matrices for the 3D space groups + implicit none + + ! Arguments + type(sym_type), intent(inout) :: grp + !! Instance of the symmetry container + real(real32), dimension(3,3), intent(in) :: lat + !! The lattice matrix + real(real32), intent(in) :: tol_sym + !! Tolerance for symmetry operations + + ! Local variables + integer :: i, count, old_count, jsym + real(real32) :: cosPi3,sinPi3,mcosPi3,msinPi3 + real(real32), dimension(3,3) :: inversion,invlat,tmat1 + real(real32), dimension(3,3,64) :: fundam_mat + real(real32), dimension(3,3,128) :: tmp_store + + + cosPi3 = 0.5_real32 + sinPi3 = sin(pi/3._real32) + mcosPi3 = -cosPi3 + msinPi3 = -sinPi3 + + + fundam_mat(1:3,1:3,1)=transpose(reshape((/& + 1._real32, 0._real32, 0._real32, 0._real32, 1._real32, 0._real32, 0._real32, 0._real32, 1._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,2)=transpose(reshape((/& + -1._real32, 0._real32, 0._real32, 0._real32, -1._real32, 0._real32, 0._real32, 0._real32, 1._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,3)=transpose(reshape((/& + -1._real32, 0._real32, 0._real32, 0._real32, 1._real32, 0._real32, 0._real32, 0._real32, -1._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,4)=transpose(reshape((/& + 1._real32, 0._real32, 0._real32, 0._real32, -1._real32, 0._real32, 0._real32, 0._real32, -1._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,5)=transpose(reshape((/& + 0._real32, 1._real32, 0._real32, 1._real32, 0._real32, 0._real32, 0._real32, 0._real32, -1._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,6)=transpose(reshape((/& + 0._real32, -1._real32, 0._real32, -1._real32, 0._real32, 0._real32, 0._real32, 0._real32, -1._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,7)=transpose(reshape((/& + 0._real32, -1._real32, 0._real32, 1._real32, 0._real32, 0._real32, 0._real32, 0._real32, 1._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,8)=transpose(reshape((/& + 0._real32, 1._real32, 0._real32, -1._real32, 0._real32, 0._real32, 0._real32, 0._real32, 1._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,9)=transpose(reshape((/& + 0._real32, 0._real32, 1._real32, 0._real32, -1._real32, 0._real32, 1._real32, 0._real32, 0._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,10)=transpose(reshape((/& + 0._real32, 0._real32, -1._real32, 0._real32, -1._real32, 0._real32, -1._real32, 0._real32, 0._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,11)=transpose(reshape((/& + 0._real32, 0._real32, -1._real32, 0._real32, 1._real32, 0._real32, 1._real32, 0._real32, 0._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,12)=transpose(reshape((/& + 0._real32, 0._real32, 1._real32, 0._real32, 1._real32, 0._real32, -1._real32, 0._real32, 0._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,13)=transpose(reshape((/& + -1._real32, 0._real32, 0._real32, 0._real32, 0._real32, 1._real32, 0._real32, 1._real32, 0._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,14)=transpose(reshape((/& + -1._real32, 0._real32, 0._real32, 0._real32, 0._real32, -1._real32, 0._real32, -1._real32, 0._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,15)=transpose(reshape((/& + 1._real32, 0._real32, 0._real32, 0._real32, 0._real32, -1._real32, 0._real32, 1._real32, 0._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,16)=transpose(reshape((/& + 1._real32, 0._real32, 0._real32, 0._real32, 0._real32, 1._real32, 0._real32, -1._real32, 0._real32/),& + shape(inversion))) + + fundam_mat(1:3,1:3,17)=transpose(reshape((/& + 0._real32, 0._real32, 1._real32, 1._real32, 0._real32, 0._real32, 0._real32, 1._real32, 0._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,18)=transpose(reshape((/& + 0._real32, 0._real32, -1._real32, -1._real32, 0._real32, 0._real32, 0._real32, 1._real32, 0._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,19)=transpose(reshape((/& + 0._real32, 0._real32, -1._real32, 1._real32, 0._real32, 0._real32, 0._real32, -1._real32, 0._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,20)=transpose(reshape((/& + 0._real32, 0._real32, 1._real32, -1._real32, 0._real32, 0._real32, 0._real32, -1._real32, 0._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,21)=transpose(reshape((/& + 0._real32, 1._real32, 0._real32, 0._real32, 0._real32, 1._real32, 1._real32, 0._real32, 0._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,22)=transpose(reshape((/& + 0._real32, -1._real32, 0._real32, 0._real32, 0._real32, -1._real32, 1._real32, 0._real32, 0._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,23)=transpose(reshape((/& + 0._real32, -1._real32, 0._real32, 0._real32, 0._real32, 1._real32, -1._real32, 0._real32, 0._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,24)=transpose(reshape((/& + 0._real32, 1._real32, 0._real32, 0._real32, 0._real32, -1._real32, -1._real32, 0._real32, 0._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,25)=transpose(reshape((/& + cosPi3, sinPi3, 0._real32, msinPi3, cosPi3, 0._real32, 0._real32, 0._real32, 1._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,26)=transpose(reshape((/& + cosPi3, msinPi3, 0._real32, sinPi3, cosPi3, 0._real32, 0._real32, 0._real32, 1._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,27)=transpose(reshape((/& + mcosPi3, sinPi3, 0._real32, msinPi3, mcosPi3, 0._real32, 0._real32, 0._real32, 1._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,28)=transpose(reshape((/& + mcosPi3, msinPi3, 0._real32, sinPi3, mcosPi3, 0._real32, 0._real32, 0._real32, 1._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,29)=transpose(reshape((/& + cosPi3, msinPi3, 0._real32, msinPi3, mcosPi3, 0._real32, 0._real32, 0._real32, -1._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,30)=transpose(reshape((/& + cosPi3, sinPi3, 0._real32, sinPi3, mcosPi3, 0._real32, 0._real32, 0._real32, -1._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,31)=transpose(reshape((/& + mcosPi3, msinPi3, 0._real32, msinPi3, cosPi3, 0._real32, 0._real32, 0._real32, -1._real32 /),& + shape(inversion))) + + fundam_mat(1:3,1:3,32)=transpose(reshape((/& + mcosPi3, sinPi3, 0._real32, sinPi3, cosPi3, 0._real32, 0._real32, 0._real32, -1._real32 /),& + shape(inversion))) + + inversion(:3,:3)=transpose(reshape((/& + -1._real32, 0._real32, 0._real32, 0._real32, -1._real32, 0._real32, 0._real32, 0._real32, -1._real32 /),& + shape(inversion))) + + + do i=1,32 + fundam_mat(:3,:3,i+32) = matmul(inversion,fundam_mat(:3,:3,i)) + end do + + + grp%nsym=0 + invlat=inverse_3x3(lat) + old_count = 0 + count = 0 + do i = 1, 64, 1 + call add_sym(grp, fundam_mat(:3,:3,i), lat, invlat, tol_sym, tmp_store, count) + if(old_count.ne.count) then + same_check1: do jsym = 1, count-1, 1 + if(all(abs(tmp_store(:3,:3,count)-tmp_store(:3,:3,jsym)).lt.tol_sym))then + count = count - 1 + exit same_check1 + end if + end do same_check1 + end if + old_count = count + call add_sym_tf(grp, fundam_mat(:3,:3,i), lat, invlat, tol_sym, tmp_store, count) + if(old_count.ne.count) then + same_check2: do jsym = 1, count-1, 1 + if(all(abs(tmp_store(:3,:3,count)-tmp_store(:3,:3,jsym)).lt.tol_sym))then + count = count - 1 + exit same_check2 + end if + end do same_check2 + end if + old_count = count + end do + + + grp%nsym = count + allocate(grp%sym(4,4,grp%nsym), source = 0._real32) + grp%sym(4,4,:) = 1._real32 + grp%sym(:3,:3,:grp%nsym) = tmp_store(:3,:3,:grp%nsym) + grp%nlatsym=grp%nsym + + end subroutine gen_fundam_sym_matrices +!############################################################################### + + +!############################################################################### + subroutine mksym(grp, lat, tol_sym) + !! Generate the symmetry operations for a given lattice + implicit none + + ! Arguments + type(sym_type), intent(inout) :: grp + !! Instance of the symmetry container + real(real32), dimension(3,3), intent(in) :: lat + !! Lattice matrix + real(real32), intent(in) :: tol_sym + !! Tolerance for symmetry operations + + ! Local variables + integer :: amin,bmin,cmin + integer :: i,j,ia,ib,ic,n,count,irot,nrot,isym,jsym, old_count + real(real32) :: tht,a,b,c + real(real32), dimension(3,3) :: rotmat,refmat,invlat,tmat1 + real(real32), allocatable, dimension(:,:,:) :: tsym1,tmp_store + logical, dimension(3) :: laxis + + + if(grp%confine%l)then + laxis = grp%confine%laxis + else + laxis = .not.grp%confine%laxis + end if + + +!!!----------------------------------------------------------------------------- +!!! initialise values and symmetry matrix +!!!----------------------------------------------------------------------------- + allocate(tsym1(4,4,50000)) + tsym1 = 0._real32 + tsym1(4,4,:) = 1._real32 + count = 0 + + +!!!----------------------------------------------------------------------------- +!!! rotation plane perp to z (1=E,2=C2,3=C3,4=C4,5=C5,6=C6) +!!!----------------------------------------------------------------------------- + if(laxis(3))then + mksyml: do n=1,10 + count=count+1 + if(n.gt.6)then + tht = -2._real32*pi/real(n-4) !=2*pi/(n-4) + else + tht = 2._real32*pi/real(n) !=2*pi/n + end if + tsym1(1:3,1:3,count)=transpose(reshape((/& + cos(tht) , sin(tht), 0._real32,& + -sin(tht), cos(tht), 0._real32,& + 0._real32 , 0._real32, 1._real32/), shape(rotmat))) + do i=1,3 + do j=1,3 + if(abs(tsym1(i,j,count)).lt.tol_sym) tsym1(i,j,count)=0._real32 + end do + end do + end do mksyml + nrot=count + end if + + +!!!----------------------------------------------------------------------------- +!!! rotation plane perp to x +!!!----------------------------------------------------------------------------- + if(laxis(1))then + philoop: do n=1,10 + if(n.gt.6)then + tht = -2._real32*pi/real(n-4) !=2*pi/n + else + tht = 2._real32*pi/real(n) !=2*pi/n + end if + rotmat = transpose(reshape((/& + 1._real32, 0._real32, 0._real32, & + 0._real32, cos(tht), sin(tht),& + 0._real32, -sin(tht), cos(tht)/), shape(rotmat))) + rot2: do irot = 1, nrot + count = count + 1 + tsym1(1:3,1:3,count) = matmul(rotmat(1:3,1:3),tsym1(1:3,1:3,irot)) + end do rot2 + end do philoop + nrot=count + end if + + +!!!----------------------------------------------------------------------------- +!!! rotation plane perp to y +!!!----------------------------------------------------------------------------- + if(laxis(2))then + psiloop: do n=1,10 + if(n.gt.6)then + tht = -2._real32*pi/real(n-4) !=2*pi/n + else + tht = 2._real32*pi/real(n) !=2*pi/n + end if + rotmat = transpose(reshape((/& + cos(tht) , 0._real32, sin(tht),& + 0._real32 , 1._real32, 0._real32, & + -sin(tht), 0._real32, cos(tht)/), shape(rotmat))) + rot3: do irot=1,nrot + count = count + 1 + tsym1(1:3,1:3,count) = matmul(rotmat(1:3,1:3),tsym1(1:3,1:3,irot)) + where (abs(tsym1(1:3,1:3,count)).lt.tol_sym) + tsym1(1:3,1:3,count) = 0._real32 + end where + end do rot3 + end do psiloop + nrot=count + end if + + +!!!----------------------------------------------------------------------------- +!!! inversion (i), x plane mirror (v), y plane mirror (v), z plane mirror (h) +!!!----------------------------------------------------------------------------- + amin=1;bmin=1;cmin=1 + if(grp%confine%lmirror)then + if(laxis(1)) amin=2 + if(laxis(2)) bmin=2 + if(laxis(3)) cmin=2 + end if + aloop: do ia=amin,2 + a=(-1._real32)**ia + bloop: do ib=bmin,2 + b=(-1._real32)**ib + cloop: do ic=cmin,2 + c=(-1._real32)**ic + ! if((a*b*c).ne.(-1._real32)) cycle cloop + refmat(1:3,1:3) = transpose(reshape((/& + a, 0._real32, 0._real32,& + 0._real32, b , 0._real32,& + 0._real32, 0._real32, c/), shape(rotmat))) + refloop: do irot = 1, nrot + count = count + 1 + tsym1(1:3,1:3,count) = matmul(refmat(1:3,1:3),tsym1(1:3,1:3,irot)) + end do refloop + end do cloop + end do bloop + end do aloop + grp%nsym = count + + + if(grp%lmolec)then + allocate(grp%sym(4,4,grp%nsym)) + grp%sym(:,:,:grp%nsym)=tsym1(:,:,:grp%nsym) + deallocate(tsym1) + return + else + invlat = inverse_3x3(lat) + end if +!!!----------------------------------------------------------------------------- +!!! checks all made symmetries to see if they apply to the supplied lattice +!!!----------------------------------------------------------------------------- + allocate(tmp_store(3,3,grp%nsym)) + count = 0 + do i = 1, grp%nsym, 1 + call add_sym_tf(grp, tsym1(:3,:3,i), lat, invlat, tol_sym, tmp_store, count) + if(old_count.ne.count) then + same_check2: do jsym = 1, count-1, 1 + if(all(abs(tmp_store(:3,:3,count)-tmp_store(:3,:3,jsym)).lt.tol_sym))then + count = count - 1 + exit same_check2 + end if + end do same_check2 + end if + old_count = count + end do + + grp%nsym = count + deallocate(tsym1) + allocate(grp%sym(4,4,grp%nsym), source = 0._real32) + grp%sym(4,4,:) = 1._real32 + grp%sym(:3,:3,:grp%nsym)=tmp_store(:3,:3,:grp%nsym) + deallocate(tmp_store) + + grp%nlatsym = grp%nsym + + end subroutine mksym +!############################################################################### + + +!############################################################################### + subroutine generate_all_symmetries(grp, lat, tol_sym) + !! Generate all possible symmetry operations for a given lattice + implicit none + + ! Arguments + type(sym_type), intent(inout) :: grp + !! Instance of the symmetry container + real(real32), dimension(3,3), intent(in) :: lat + !! Lattice matrix + real(real32), intent(in) :: tol_sym + !! Tolerance for symmetry operations + + ! Local variables + integer :: i, j, count, n + !! Counters + real(real32) :: angle + !! Angle for rotation + real(real32), dimension(3,3) :: invlat + !! Inverse lattice matrix + real(real32), dimension(3,3) :: smat, mirror, ident + !! Symmetry matrices + real(real32), allocatable :: symm_matrices(:,:,:) + !! Symmetry matrices array + real(real32), dimension(3) :: axis + !! Axis of rotation + + + allocate(symm_matrices(3,3,20000)) + count = 0 + + ident = 0._real32 + ident(1,1) = 1._real32; ident(2,2) = 1._real32; ident(3,3) = 1._real32 + invlat = inverse_3x3(lat) + + ! Off-axis mirrors (diagonal planes) + smat = ident + smat(1,1) = 0._real32; smat(1,2) = 1._real32; + smat(2,1) = 1._real32; smat(2,2) = 0._real32 + smat(3,3) = 1._real32 + call add_sym(grp, smat, lat, invlat, tol_sym, symm_matrices, count) + smat = ident + smat(1,1) = 0._real32; smat(1,2) = -1._real32 + smat(2,1) = -1._real32; smat(2,2) = 0._real32 + smat(3,3) = 1._real32 + call add_sym(grp, smat, lat, invlat, tol_sym, symm_matrices, count) + + ! Rotations around x, y, z axes (common n-fold: 2, 3, 4, 6) + do j = 1, 8 + mirror = ident + if(j.gt.5) then + mirror = -ident + mirror(j-5,j-5) = 1._real32 + elseif(j.gt.2) then + mirror(j-2,j-2) = -1._real32 + elseif(j.eq.2)then + mirror = -ident + end if + + do i = 1, 3 + do n = 1, 10 + if(n.gt.6)then + angle = -2._real32*pi/real(n-4, real32) !=2*pi/(n-4) + else + angle = 2._real32*pi/real(n, real32) !=2*pi/n + end if + smat = rotation_matrix(i, angle) + smat = matmul(smat, mirror) + call add_sym(grp, smat, lat, invlat, tol_sym, symm_matrices, count) + end do + end do + + ! Rotations around body diagonals (e.g. [111], [110]) + do i = 1, 11 + axis = uvec([1._real32, 1._real32, 1._real32]) + if(i.eq.11)then + axis = -axis + elseif(i.gt.7) then + axis = -axis + axis(i-7) = 1._real32 + elseif(i.gt.4)then + axis(i-4) = -1._real32 + elseif(i.gt.1) then + axis(i-1) = 0._real32 + end if + do n = 1, 10 + if(n.gt.6)then + angle = -2._real32*pi/real(n-4, real32) !=2*pi/(n-4) + else + angle = 2._real32*pi/real(n, real32) !=2*pi/n + end if + smat = rotate_about_axis(axis, angle) + smat = matmul(smat, mirror) + call add_sym(grp, smat, lat, invlat, tol_sym, symm_matrices, count) + end do + end do + end do + + ! Trim to valid + grp%nsym = count + allocate(grp%sym(4,4,grp%nsym), source=0._real32) + grp%sym(:3,:3,:) = symm_matrices(:3,:3,1:count) + count = 0 + sym_check: do i = 1, grp%nsym + do j = 1, count, 1 + if(all(abs(grp%sym(:3,:3,i)-symm_matrices(:3,:3,j)).lt.tol_sym)) then + cycle sym_check + end if + end do + count = count + 1 + symm_matrices(1:3,1:3,count) = grp%sym(:3,:3,i) + end do sym_check + grp%nsym = count + deallocate(grp%sym) + allocate(grp%sym(4,4,grp%nsym), source=0._real32) + grp%sym(:3,:3,:) = symm_matrices(:3,:3,1:count) + grp%sym(4,4,:) = 1._real32 + deallocate(symm_matrices) + grp%nlatsym = grp%nsym + + contains + + function rotation_matrix(axis, angle) result(output) + implicit none + integer, intent(in) :: axis + real(real32), intent(in) :: angle + real(real32) :: output(3,3), c, s + c = cos(angle); s = sin(angle) + if (axis == 1) then + output = reshape([1._real32,0._real32,0._real32, 0._real32,c,s, 0._real32,-s,c], [3,3]) + elseif (axis == 2) then + output = reshape([c,0._real32,-s, 0._real32,1._real32,0._real32, s,0._real32,c], [3,3]) + else + output = reshape([c,s,0._real32, -s,c,0._real32, 0._real32,0._real32,1._real32], [3,3]) + end if + end function rotation_matrix + + function rotate_about_axis(ax, angle) result(output) + implicit none + real(real32), intent(in) :: ax(3), angle + real(real32) :: output(3,3), c, s, v + real(real32) :: x, y, z + x = ax(1); y = ax(2); z = ax(3) + c = cos(angle); s = sin(angle); v = 1 - c + output(1,1) = x*x*v + c + output(1,2) = x*y*v - z*s + output(1,3) = x*z*v + y*s + output(2,1) = y*x*v + z*s + output(2,2) = y*y*v + c + output(2,3) = y*z*v - x*s + output(3,1) = z*x*v - y*s + output(3,2) = z*y*v + x*s + output(3,3) = z*z*v + c + end function rotate_about_axis + + end subroutine generate_all_symmetries +!############################################################################### + + +!############################################################################### + subroutine add_sym(grp, mat, lat, invlat, tol_sym, store, count) + !! Add symmetry matrix to the store if valid + implicit none + + ! Arguments + type(sym_type), intent(in) :: grp + !! Instance of symmetry container + real(real32), dimension(3,3), intent(in) :: mat + !! Symmetry matrix + real(real32), dimension(3,3), intent(in) :: lat, invlat + !! Lattice and inverse lattice matrices + real(real32), intent(in) :: tol_sym + !! Tolerance for symmetry check + real(real32), intent(inout) :: store(:,:,:) + !! Store for symmetry matrices + integer, intent(inout) :: count + !! Counter for number of valid symmetries + + if (is_valid_symmetry(grp, mat, tol_sym))then + count = count + 1 + store(:3,:3,count) = mat + end if + end subroutine add_sym +!------------------------------------------------------------------------------- + subroutine add_sym_tf(grp, mat, lat, invlat, tol_sym, store, count) + !! Add the coordinate transformed symmetry matrix to the store if valid + implicit none + + ! Arguments + type(sym_type), intent(in) :: grp + !! Instance of symmetry container + real(real32), dimension(3,3), intent(in) :: mat + !! Symmetry matrix + real(real32), dimension(3,3), intent(in) :: lat, invlat + !! Lattice and inverse lattice matrices + real(real32), intent(in) :: tol_sym + !! Tolerance for symmetry check + real(real32), intent(inout) :: store(:,:,:) + !! Store for symmetry matrices + integer, intent(inout) :: count + !! Counter for number of valid symmetries + + ! Local variables + real(real32) :: t(3,3) + !! Transformed symmetry operation + + ! t = matmul(invlat, matmul(mat, lat)) + t = matmul(lat, matmul(mat, invlat)) + if (is_valid_symmetry(grp, t, tol_sym))then + count = count + 1 + store(:3,:3,count) = t + end if + end subroutine add_sym_tf +!------------------------------------------------------------------------------- + function is_valid_symmetry(grp, mat, tol_sym) result(output) + !! Check if the symmetry matrix is valid + implicit none + + ! Arguments + type(sym_type), intent(in) :: grp + !! Instance of symmetry container + real(real32), dimension(3,3), intent(in) :: mat + !! Symmetry matrix + real(real32), intent(in) :: tol_sym + !! Tolerance for symmetry check + logical :: output + !! Result of the symmetry check + + ! Local variables + integer :: i + !! Loop index + real(real32), dimension(3) :: compare_vec, input_vec + !! Vectors for comparison + + output = & + all(abs(mat - nint(mat)) .lt. tol_sym) .and. & + abs(abs(det(mat)) - 1._real32) .lt. tol_sym + + if(grp%lmolec) then + output = output .and. all(abs(mat) .lt. 1._real32 + tol_sym) + end if + do i = 1, 3 + if(grp%confine%lmirror)then + input_vec = mat(i,:) + else + input_vec = abs(mat(:,i)) + end if + if( ( grp%confine%l .and. grp%confine%laxis(i) ) .or. & + ( & + .not.grp%confine%l .and. & + grp%confine%lmirror .and. & + grp%confine%laxis(i) & + ) & + ) then + compare_vec = 0._real32 + compare_vec(i) = 1._real32 + output = output .and. & + all(abs(input_vec - compare_vec) .lt. tol_sym) + end if + end do + + end function is_valid_symmetry +!############################################################################### + + +!!!############################################################################# +!!! returns the wyckoff atoms of a basis (closest to a defined location) +!!!############################################################################# + function get_wyckoff_atoms_any(wyckoff) result(wyckoff_atoms) + implicit none + integer :: i,is,ia,isym,imin,itmp1 + integer :: nsym,nspec + type(wyck_type) :: wyckoff_atoms + integer, allocatable, dimension(:) :: ivtmp1 + + type(wyck_type), dimension(:), intent(in) :: wyckoff + + + nsym = size(wyckoff) + nspec = size(wyckoff(1)%spec(:)) + allocate(wyckoff_atoms%spec(nspec)) + wyckoff_atoms%spec(:)%num = 0 + do is=1,nspec + allocate(ivtmp1(size(wyckoff(1)%spec(is)%atom))) + ivtmp1 = 0 + do ia=1,size(wyckoff(1)%spec(is)%atom) + + imin = wyckoff(1)%spec(is)%atom(ia) + if(imin.eq.0)then + write(0,'("ERROR: imin in get_wyckoff_atoms is zero!!!")') + write(0,'("Exiting...")') + stop + end if + sym_loop1: do isym=2,nsym + if(wyckoff(isym)%spec(is)%atom(ia).eq.0) cycle sym_loop1 + if(wyckoff(isym)%spec(is)%atom(ia).lt.imin)& + imin = wyckoff(isym)%spec(is)%atom(ia) + end do sym_loop1 + sym_loop2: do + itmp1 = minval( (/ (wyckoff(i)%spec(is)%atom(imin),i=1,nsym) /),& + mask=(/ (wyckoff(i)%spec(is)%atom(imin),i=1,nsym) /).gt.0 ) + if(itmp1.ne.imin)then + imin=itmp1 + else + exit sym_loop2 + end if + end do sym_loop2 + + if(.not.any(ivtmp1(:).eq.imin))then + wyckoff_atoms%spec(is)%num = wyckoff_atoms%spec(is)%num+1 + ivtmp1(wyckoff_atoms%spec(is)%num) = imin + end if + + end do + allocate(wyckoff_atoms%spec(is)%atom(wyckoff_atoms%spec(is)%num)) + wyckoff_atoms%spec(is)%atom(:)=ivtmp1(:wyckoff_atoms%spec(is)%num) + deallocate(ivtmp1) + end do + wyckoff_atoms%nwyck = sum(wyckoff_atoms%spec(:)%num) + + + end function get_wyckoff_atoms_any +!!!----------------------------------------------------------------------------- +!!!----------------------------------------------------------------------------- + function get_wyckoff_atoms_loc(wyckoff,lat,bas,loc) result(wyckoff_atoms) + implicit none + integer :: is,ia,isym,imin,itmp1 + integer :: nsym + real(real32) :: dist + logical :: lfound_closer + type(wyck_type) :: wyckoff_atoms + real(real32), dimension(3) :: diff + real(real32), allocatable, dimension(:) :: dists + integer, allocatable, dimension(:) :: ivtmp1 + + type(basis_type), intent(in) :: bas + real(real32), dimension(3), intent(in) :: loc + type(wyck_type), dimension(:), intent(in) :: wyckoff + real(real32), dimension(3,3), intent(in) :: lat + + + nsym = size(wyckoff) + allocate(wyckoff_atoms%spec(bas%nspec)) + wyckoff_atoms%spec(:)%num = 0 + do is=1,bas%nspec + allocate(ivtmp1(size(wyckoff(1)%spec(is)%atom))) + ivtmp1 = 0 + + allocate(dists(bas%spec(is)%num)) + do ia=1,bas%spec(is)%num + diff = loc - bas%spec(is)%atom(ia,:3) + diff = diff - ceiling(diff - 0.5_real32) + dists(ia) = modu(matmul(diff,lat)) + end do + + wyckoff_loop1: do ia=1,size(wyckoff(1)%spec(is)%atom) + + dist = huge(0._real32) + imin = wyckoff(1)%spec(is)%atom(ia) + sym_loop1: do isym=1,nsym + if(wyckoff(isym)%spec(is)%atom(ia).eq.0) cycle sym_loop1 + + if(dists(wyckoff(isym)%spec(is)%atom(ia)).lt.dist)then + dist = dists(wyckoff(isym)%spec(is)%atom(ia)) + imin = wyckoff(isym)%spec(is)%atom(ia) + end if + end do sym_loop1 + if(any(ivtmp1(:).eq.imin)) cycle wyckoff_loop1 + + sym_loop2: do + lfound_closer = .false. + sym_loop3: do isym=1,nsym + if(wyckoff(isym)%spec(is)%atom(imin).eq.0) cycle sym_loop3 + if(wyckoff(isym)%spec(is)%atom(imin).eq.imin) cycle sym_loop3 + if(dists(wyckoff(isym)%spec(is)%atom(imin)).lt.dist)then + dist = dists(wyckoff(isym)%spec(is)%atom(imin)) + itmp1 = wyckoff(isym)%spec(is)%atom(imin) + lfound_closer = .true. + elseif(dists(wyckoff(isym)%spec(is)%atom(imin)).eq.dist)then + if(any(ivtmp1(:).eq.wyckoff(isym)%spec(is)%atom(imin)))then + dist = dists(wyckoff(isym)%spec(is)%atom(imin)) + itmp1 = wyckoff(isym)%spec(is)%atom(imin) + lfound_closer = .true. + end if + end if + end do sym_loop3 + if(lfound_closer)then + imin = itmp1 + else + exit sym_loop2 + end if + end do sym_loop2 + + + if(.not.any(ivtmp1(:).eq.imin))then + wyckoff_atoms%spec(is)%num = wyckoff_atoms%spec(is)%num+1 + ivtmp1(wyckoff_atoms%spec(is)%num) = imin + end if + if(imin.eq.0)then + write(0,'("ERROR: imin in get_wyckoff_atoms is zero!!!")') + write(0,'("Exiting...")') + stop + end if + + end do wyckoff_loop1 + allocate(wyckoff_atoms%spec(is)%atom(wyckoff_atoms%spec(is)%num)) + wyckoff_atoms%spec(is)%atom(:)=ivtmp1(:wyckoff_atoms%spec(is)%num) + deallocate(ivtmp1) + deallocate(dists) + end do + wyckoff_atoms%nwyck = sum(wyckoff_atoms%spec(:)%num) + + + end function get_wyckoff_atoms_loc +!!!############################################################################# + + +!!!############################################################################# +!!! find corresponding basis2 atoms that the supplied symmetry operation ... +!!! ... maps basis1 atoms onto. +!!! Basis2 is optional. If missing, it uses basis1 for the comparison +!!!############################################################################# + function basis_map(sym,bas1,tmpbas2, tol_sym) result(bas_map) + implicit none + real(real32), dimension(4,4), intent(in) :: sym + type(basis_type), intent(in) :: bas1 + type(basis_type), optional, intent(in) :: tmpbas2 + real(real32), intent(in), optional :: tol_sym + + integer :: j,ispec,iatom,jatom,dim + type(basis_map_type) :: bas_map + type(basis_type) :: bas2,tfbas + real(real32), dimension(3) :: diff + + +!!!----------------------------------------------------------------------------- +!!! checks for optional arguments and assigns values if not present +!!!----------------------------------------------------------------------------- + allocate(bas2%spec(bas1%nspec)) + dim=size(bas1%spec(1)%atom(1,:),dim=1) + do ispec=1,bas1%nspec + allocate(bas2%spec(ispec)%atom(bas1%spec(ispec)%num,dim)) + end do + if(present(tmpbas2)) then + bas2 = tmpbas2 + else + bas2 = bas1 + end if + + +!!!----------------------------------------------------------------------------- +!!! sets up basis map +!!!----------------------------------------------------------------------------- + allocate(bas_map%spec(bas1%nspec)) + do ispec=1,bas1%nspec + allocate(bas_map%spec(ispec)%atom(bas1%spec(ispec)%num)) + bas_map%spec(ispec)%atom(:)=0 + end do + allocate(tfbas%spec(bas1%nspec)) + do ispec=1,bas1%nspec + allocate(tfbas%spec(ispec)%atom(bas1%spec(ispec)%num,4)) + end do + + +!!!----------------------------------------------------------------------------- +!!! apply symmetry operator to bas1 +!!!----------------------------------------------------------------------------- + do ispec=1,bas1%nspec + do iatom=1,bas1%spec(ispec)%num + tfbas%spec(ispec)%atom(iatom,1:3) = & + matmul(bas1%spec(ispec)%atom(iatom,1:4),sym(1:4,1:3)) + do j=1,3 + tfbas%spec(ispec)%atom(iatom,j) = & + tfbas%spec(ispec)%atom(iatom,j) - & + ceiling(tfbas%spec(ispec)%atom(iatom,j) - 0.5_real32) + bas2%spec(ispec)%atom(iatom,j) = & + bas2%spec(ispec)%atom(iatom,j) - & + ceiling(bas2%spec(ispec)%atom(iatom,j) - 0.5_real32) + end do + end do + end do + + +!!!----------------------------------------------------------------------------- +!!! check whether transformed basis matches original basis +!!!----------------------------------------------------------------------------- + spcheck2: do ispec=1,bas1%nspec + diff=0._real32 + atmcheck2: do iatom=1,bas1%spec(ispec)%num + atmcyc2: do jatom=1,bas1%spec(ispec)%num + if(any(bas_map%spec(ispec)%atom(:).eq.jatom)) cycle atmcyc2 + diff = tfbas%spec(ispec)%atom(iatom,1:3) - & + bas2%spec(ispec)%atom(jatom,1:3) + diff = diff - ceiling(diff - 0.5_real32) + if(sqrt(dot_product(diff,diff)).lt.tol_sym)then + bas_map%spec(ispec)%atom(iatom) = jatom + end if + end do atmcyc2 + end do atmcheck2 + end do spcheck2 + + + return + end function basis_map +!!!############################################################################# + +end module artemis__sym diff --git a/src/fortran/lib/mod_terminations.f90 b/src/fortran/lib/mod_terminations.f90 new file mode 100644 index 0000000..25e15eb --- /dev/null +++ b/src/fortran/lib/mod_terminations.f90 @@ -0,0 +1,1098 @@ +module artemis__terminations + !! Module for handling termination identification and generation + use artemis__constants, only: real32 + use artemis__geom_rw, only: basis_type, geom_write + use artemis__misc, only: sort_col, to_lower, to_upper + use artemis__io_utils, only: err_abort, stop_program + use artemis__io_utils_extd, only: err_abort_print_struc + use misc_linalg, only: modu, cross, uvec, det + use artemis__sym, only: sym_type, check_sym + use artemis__geom_utils, only: shifter, transformer, ortho_axis, set_vacuum + implicit none + + + private + + public :: term_arr_type + public :: get_termination_info + public :: set_layer_tol + public :: build_slab_supercell + public :: cut_slab_to_height + + + type term_type + !! Structure to hold termination information + real(real32) :: hmin + real(real32) :: hmax + integer :: natom = 0 + integer :: nstep = 0 + real(real32), allocatable, dimension(:) :: ladder + end type term_type + + type term_arr_type + !! Structure to hold arrays of terminations + integer :: nterm = 0, axis, nstep + real(real32) :: tol + logical :: lmirror=.false. + type(term_type), allocatable, dimension(:) :: arr + end type term_arr_type + + type term_list_type + !! Structure to hold termination index and location + integer :: term + real(real32) :: loc + end type term_list_type + + + +contains + +!############################################################################### + function get_termination_info( & + basis, axis, verbose, tol_sym, layer_sep, exit_code & + ) result(term) + !! Function to find the terminations of a material along a given axis + implicit none + + ! Arguments + type(basis_type), intent(in) :: basis + !! Basis structure + integer, intent(in) :: axis + !! Axis to find terminations along (1,2,3) + !! 1=a, 2=b, 3=c + integer, intent(in) :: verbose + !! Verbosity level + real(real32), intent(in) :: tol_sym + !! Tolerance for symmetry operations + real(real32), intent(in) :: layer_sep + !! Minimum separation between layers + integer, intent(inout) :: exit_code + + ! Local variables + integer :: unit + !! File unit number + integer :: i, j, k, is, nterm, mterm, dim, ireject + !! Loop indices and dimensions + integer :: itmp1, itmp2, init, min_loc + !! Temporary indices + logical :: lunique, ltmp1, lmirror + !! Boolean flags + real(real32) :: rtmp1, height, max_sep, c_along, centre + !! Temporary variables + real(real32) :: layer_sep_ + !! Minimum separation between layers + type(sym_type) :: grp1, grp_store, grp_store_inv + !! Symmetry group structure + type(term_arr_type) :: term + !! Termination information + integer, dimension(3) :: abc + !! Axis indices + real(real32), dimension(3) :: vec_compare + !! Comparison vector + real(real32), dimension(3,3) :: inv_mat, ident + !! Inversion and identity matrix + type(basis_type),allocatable, dimension(:) :: basis_arr, basis_arr_reject + !! Basis structures for terminations + type(term_type), allocatable, dimension(:) :: term_arr, term_arr_uniq + !! Termination information + integer, allocatable, dimension(:) :: success, tmpop + !! Temporary symmetry operations + integer, allocatable, dimension(:,:) :: reject_match + !! Rejection match array + real(real32), allocatable, dimension(:,:) :: basis_list + !! List of basis atoms + real(real32), allocatable, dimension(:,:,:) :: tmpsym + !! Temporary symmetry matrix + character(len=256) :: err_msg + !! Error message + integer, dimension(:), allocatable :: comparison_list + !! List of terminations to compare against + + + abc = [ 1, 2, 3 ] + term%nterm = 0 + grp_store%end_idx = 0 + grp_store%confine%l=.false. + grp_store%confine%axis=axis + grp_store%confine%laxis=.false. + !--------------------------------------------------------------------------- + ! Set the surface identification tolerance + !--------------------------------------------------------------------------- + layer_sep_ = layer_sep + + abc=cshift(abc,3-axis) + c_along = abs(dot_product(basis%lat(axis,:),& + uvec(cross([basis%lat(abc(1),:)],[basis%lat(abc(2),:)])))) + layer_sep_ = layer_sep_ / c_along + lmirror=.false. + + + !--------------------------------------------------------------------------- + ! Set up basis list that will order them wrt distance along 'axis' + !--------------------------------------------------------------------------- + allocate(basis_list(basis%natom,3)) + init = 1 + do is=1,basis%nspec + basis_list(init:init+basis%spec(is)%num-1,:3) = basis%spec(is)%atom(:,:3) + init = init + basis%spec(is)%num + end do + call sort_col(basis_list,col=axis) + + + !--------------------------------------------------------------------------- + ! Find largest separation between atoms + !--------------------------------------------------------------------------- + max_sep = basis_list(1,axis) - (basis_list(basis%natom,axis)-1._real32) + height = ( basis_list(1,axis) + (basis_list(basis%natom,axis)-1._real32) )/2._real32 + do i=1,basis%natom-1 + rtmp1 = basis_list(i+1,axis) - basis_list(i,axis) + if(rtmp1.gt.max_sep)then + max_sep = rtmp1 + height = ( basis_list(i+1,axis) + basis_list(i,axis) )/2._real32 + end if + end do + if(max_sep.lt.layer_sep_)then + exit_code = 1 + write(0,'("ERROR: Error in artemis__sym.f90")') + write(0,'(2X,"get_terminations subroutine unable to find a separation & + &in the material that is greater than LAYER_SEP")') + write(0,'(2X,"Writing material to ''unlayerable.vasp''")') + open(newunit=unit, file="unlayerable.vasp") + call geom_write(unit, basis) + close(unit) + write(0,'(2X,"We suggest reducing LAYER_SEP to less than ",F6.4)') & + max_sep + write(0,'(2X,"NOTE: If LAYER_SEP < 0.7, the material likely does not & + &support the Miller plane")') + write(0,'(2X,"Please inform the developers of this and give details & + &of what structure caused this")') + return + end if + basis_list(:,axis) = basis_list(:,axis) - height + basis_list(:,axis) = basis_list(:,axis) - floor(basis_list(:,axis)) + call sort_col(basis_list,col=axis) + + + !--------------------------------------------------------------------------- + ! Find number of non-unique terminations + !--------------------------------------------------------------------------- + nterm=1 + allocate(term_arr(basis%natom)) + term_arr(:)%natom=0 + term_arr(:)%hmin=0 + term_arr(:)%hmax=0 + term_arr(1)%hmin=basis_list(1,axis) + term_arr(1)%hmax=basis_list(1,axis) + min_loc = 1 + itmp1 = 1 + term_loop1: do + + ! get the atom at that height + itmp1 = minloc(basis_list(:,axis) - term_arr(nterm)%hmax, dim=1, & + mask = basis_list(:,axis) - term_arr(nterm)%hmax.gt.0._real32) + if(itmp1.gt.basis%natom.or.itmp1.le.0)then + term_arr(nterm)%natom = basis%natom - min_loc + 1 + exit term_loop1 + end if + + rtmp1 = basis_list(itmp1,axis) - term_arr(nterm)%hmax + if(rtmp1.le.layer_sep_)then + term_arr(nterm)%hmax = basis_list(itmp1,axis) + else + term_arr(nterm)%natom = itmp1 - min_loc + min_loc = itmp1 + nterm = nterm + 1 + term_arr(nterm)%hmin = basis_list(itmp1,axis) + term_arr(nterm)%hmax = basis_list(itmp1,axis) + end if + + end do term_loop1 + term_arr(:nterm)%hmin = term_arr(:nterm)%hmin + height + term_arr(:nterm)%hmax = term_arr(:nterm)%hmax + height + + + !--------------------------------------------------------------------------- + ! Set up system symmetries + !--------------------------------------------------------------------------- + allocate(basis_arr(2*nterm)) + allocate(basis_arr_reject(2*nterm)) + dim = size(basis%spec(1)%atom(1,:)) + do i=1,2*nterm + allocate(basis_arr(i)%spec(basis%nspec)) + allocate(basis_arr_reject(i)%spec(basis%nspec)) + do is=1,basis%nspec + allocate(basis_arr(i)%spec(is)%atom(& + basis%spec(is)%num,dim)) + allocate(basis_arr_reject(i)%spec(is)%atom(& + basis%spec(is)%num,dim)) + end do + end do + + + !--------------------------------------------------------------------------- + ! Print location of unique terminations + !--------------------------------------------------------------------------- + ireject = 0 + grp_store%lspace = .true. + grp_store%confine%l = .true. + grp_store%confine%laxis(axis) = .true. + call grp_store%init( & + basis%lat, & + predefined=.true., new_start=.true., & + tol_sym=tol_sym & + ) + + + !--------------------------------------------------------------------------- + ! Handle inversion matrix (centre of inversion must be accounted for) + !--------------------------------------------------------------------------- + ! change symmetry constraints after setting up symmetries + ! this is done to constrain the matching of two basises in certain directions + grp_store%confine%l = .false. + grp_store%confine%laxis(axis) = .false. + call check_sym(grp_store,basis=basis,iperm=-1,lsave=.true.,tol_sym=tol_sym) + inv_mat = 0._real32 + do i=1,3 + inv_mat(i,i) = -1._real32 + end do + itmp1 = 0 + do i = 1, grp_store%nsym + if(all(abs(grp_store%sym(:3,:3,i)-inv_mat).lt.tol_sym))then + itmp1 = i + exit + end if + end do + if(itmp1.eq.0)then + ! call stop_program("No inversion symmetry found!") + ! exit_code = max(exit_code, 1) + ! return + else + do i = 1, grp_store%nsym + if(all(abs(grp_store%sym(:3,:3,i)-inv_mat).lt.tol_sym)) & + grp_store%sym(4,:3,itmp1) = grp_store%sym(4,:3,i) + end do + end if + + + + !--------------------------------------------------------------------------- + ! Determine unique surface terminations + !--------------------------------------------------------------------------- + grp_store%confine%l = .true. + grp_store%confine%laxis(axis) = .true. + allocate(term_arr_uniq(2*nterm)) + allocate(reject_match(nterm,2)) + mterm = 0 + shift_loop1: do i = 1, nterm, 1 + mterm = mterm + 1 + + basis_arr(mterm) = basis + centre = term_arr(i)%hmin + (term_arr(i)%hmax - term_arr(i)%hmin)/2._real32 + call shifter(basis_arr(mterm),axis,1._real32 - centre,.true.) + sym_if: if(i.ne.1)then + sym_loop1: do j = 1, mterm - 1, 1 + if(abs(abs(term_arr(i)%hmax-term_arr(i)%hmin) - & + abs(term_arr_uniq(j)%hmax-term_arr_uniq(j)%hmin)).gt.tol_sym) & + cycle sym_loop1 + call grp1%copy(grp_store) + call check_sym(grp1,basis=basis_arr(mterm),& + iperm=-1,tmpbas2=basis_arr(j),lsave=.true.,tol_sym=tol_sym) + if(grp1%nsymop.ne.0)then + if(abs(grp1%sym_save(axis,axis,1)+1._real32).lt.tol_sym)then + ireject = ireject + 1 + reject_match(ireject,:) = [ i, j ] + basis_arr_reject(ireject) = basis_arr(mterm) + lmirror=.true. + else + term_arr_uniq(j)%nstep = term_arr_uniq(j)%nstep + 1 + term_arr_uniq(j)%ladder(term_arr_uniq(j)%nstep) = & + term_arr(i)%hmin - term_arr_uniq(j)%hmin + end if + mterm = mterm - 1 + cycle shift_loop1 + end if + end do sym_loop1 + end if sym_if + term_arr_uniq(mterm) = term_arr(i) + term_arr_uniq(mterm)%nstep = 1 + allocate(term_arr_uniq(mterm)%ladder(nterm)) + term_arr_uniq(mterm)%ladder(:) = 0._real32 + end do shift_loop1 + + + !--------------------------------------------------------------------------- + ! Set up mirror/inversion symmetries of the matrix + !--------------------------------------------------------------------------- + grp_store_inv%confine%axis = axis + grp_store_inv%confine%laxis = .false. + grp_store_inv%lspace = .true. + grp_store_inv%confine%l = .true. + grp_store_inv%confine%laxis(axis) = .true. + call grp_store_inv%init( & + basis%lat, & + predefined=.true., new_start=.true., & + tol_sym=tol_sym & + ) + itmp1 = count(abs(grp_store_inv%sym(3,3,:)+1._real32).lt.tol_sym) + allocate(tmpsym(4,4,itmp1)) + allocate(tmpop(itmp1)) + itmp1 = 0 + do i = 1, grp_store_inv%nsym + if(abs(grp_store_inv%sym(3,3,i)+1._real32).lt.tol_sym)then + itmp1=itmp1+1 + tmpsym(:,:,itmp1) = grp_store_inv%sym(:,:,i) + tmpop(itmp1) = i + end if + end do + grp_store_inv%nsym = itmp1 + grp_store_inv%nlatsym = itmp1 + call move_alloc(tmpsym,grp_store_inv%sym) + allocate(grp_store_inv%op(itmp1)) + grp_store_inv%op(:) = tmpop(:itmp1) + grp_store_inv%end_idx = grp_store_inv%nsym + + + !--------------------------------------------------------------------------- + ! Check rejects for inverse surface termination of saved + !--------------------------------------------------------------------------- + ident = 0._real32 + do i=1,3 + ident(i,i) = 1._real32 + end do + vec_compare = 0._real32 + vec_compare(axis) = -1._real32 + allocate(success(ireject)) + success=0 + reject_loop1: do i=1,ireject + lunique=.true. + itmp1=reject_match(i,1) + itmp2=reject_match(i,2) + ! Check if comparison termination has already been compared successfully + comparison_list = [ itmp2 ] + !! check against all previous reject-turned-unique terminations + prior_check: if(any(success(1:i-1:1).eq.itmp2))then + do j = 1, i-1, 1 + if(success(j).eq.itmp2)then + grp_store%end_idx = grp_store%nsym + call grp1%copy(grp_store) + call check_sym(grp1,basis=basis_arr_reject(j),& + iperm=-1,tmpbas2=basis_arr_reject(i),lsave=.true., & + tol_sym=tol_sym & + ) + if(grp1%nsymop.ne.0)then + if(abs(grp1%sym_save(axis,axis,1)+1._real32).gt.tol_sym)then + lunique = .false. + itmp2 = reject_match(j,2) + exit prior_check + end if + end if + comparison_list = [ comparison_list, reject_match(j,2) ] + end if + end do + end if prior_check + + unique_condition1: if(lunique)then + grp_store_inv%end_idx = grp_store_inv%nsym + lunique = .true. + do k = 1, size(comparison_list) + itmp2 = comparison_list(k) + call grp1%copy(grp_store_inv) + grp1%confine%l = .false. + call check_sym(grp1,basis_arr(itmp2),& + iperm=-1,lsave=.true.,check_all_sym=.true., & + tol_sym=tol_sym & + ) + + !! Check if inversions are present in comparison termination + ltmp1=.false. + do j = 1, grp1%nsymop, 1 + if(abs(det(grp1%sym_save(:3,:3,j))+1._real32).le.tol_sym) ltmp1=.true. + end do + !! If they are not, then no point comparing. It is a new termination + if(.not.ltmp1) cycle + + call grp1%copy(grp_store_inv) + call check_sym(grp1,basis_arr(itmp2),& + tmpbas2=basis_arr_reject(i), & + iperm=-1, & + lsave=.true., & + check_all_sym=.true., & + tol_sym=tol_sym & + ) + + !! Check det of all symmetry operations. If any are 1, move on + !! This is because they are just rotations as can be captured ... + !! ... through lattice matches. + !! Solely inversions are unique and must be captured. + do j = 1, grp1%nsymop, 1 + if(abs(det(grp1%sym_save(:3,:3,j))-1._real32).le.tol_sym) lunique=.false. + end do + if(grp1%sym_save(4,axis,1).eq.& + 2._real32 * min( & + term_arr_uniq(itmp2)%hmin, & + 0.5_real32 - term_arr_uniq(itmp2)%hmin & + ) & + ) lunique=.false. + + if(.not.( & + all(abs(grp1%sym_save(axis,:3,1) - vec_compare(:)).lt.tol_sym).and.& + all(abs(grp1%sym_save(:3,axis,1) - vec_compare(:)).lt.tol_sym) & + ) ) lunique=.false. + + if(lunique) exit unique_condition1 + end do + end if unique_condition1 + + if(lunique)then + mterm = mterm + 1 + success(i) = itmp2 + basis_arr(mterm) = basis_arr_reject(i) + term_arr_uniq(mterm) = term_arr(itmp1) + reject_match(i,2) = mterm + term_arr_uniq(mterm)%nstep = 1 + allocate(term_arr_uniq(mterm)%ladder(ireject+1)) + term_arr_uniq(mterm)%ladder(1) = 0._real32 + else + term_arr_uniq(itmp2)%nstep = term_arr_uniq(itmp2)%nstep + 1 + term_arr_uniq(itmp2)%ladder(term_arr_uniq(itmp2)%nstep) = & + term_arr(itmp1)%hmin - term_arr_uniq(itmp2)%hmin + end if + end do reject_loop1 + + + !--------------------------------------------------------------------------- + ! Populate termination output + !--------------------------------------------------------------------------- + allocate(term%arr(mterm)) + term%tol=layer_sep_ + term%axis=axis + term%nterm=mterm + term%lmirror = lmirror + if(verbose.gt.0)& + write(*,'(1X,"Term.",3X,"Min layer loc",3X,"Max layer loc",3X,"no. atoms")') + rtmp1 = term_arr_uniq(1)%hmin - 1.E-6_real32 + itmp1 = 1 + do i = 1, mterm, 1 + allocate(term%arr(i)%ladder(term_arr_uniq(i)%nstep)) + term%arr(i)%hmin = term_arr_uniq(itmp1)%hmin + term%arr(i)%hmax = term_arr_uniq(itmp1)%hmax + term%arr(i)%natom = term_arr_uniq(itmp1)%natom + term%arr(i)%nstep = term_arr_uniq(itmp1)%nstep + term%arr(i)%ladder(:term%arr(i)%nstep) = & + term_arr_uniq(i)%ladder(:term%arr(i)%nstep) + if(verbose.gt.0) write(*,'(1X,I3,8X,F7.5,9X,F7.5,8X,I3)') & + i,term%arr(i)%hmin,term%arr(i)%hmax,term%arr(i)%natom + itmp1 = minloc(term_arr_uniq(:)%hmin,& + mask=term_arr_uniq(:)%hmin.gt.rtmp1+layer_sep_,dim=1) + if(itmp1.eq.0) then + itmp1 = minloc(term_arr_uniq(:)%hmin,& + mask=term_arr_uniq(:)%hmin.gt.rtmp1+layer_sep_-1._real32,dim=1) + end if + rtmp1 = term_arr_uniq(itmp1)%hmin + end do + term%nstep = maxval(term%arr(:)%nstep) + + + !--------------------------------------------------------------------------- + ! Check to ensure equivalent number of steps for each termination + !--------------------------------------------------------------------------- + ! Not yet certain whether each termination should have same number ... + ! ... of ladder rungs. That's why this check is here. + if(all(term%arr(:)%nstep.ne.term%nstep))then + write(0,'("ERROR: Number of rungs in terminations no equivalent for & + &every termination! Please report this to developers.\n& + &Exiting...")') + call exit() + end if + + + end function get_termination_info +!############################################################################### + + +!############################################################################### + function get_term_list(term) result(list) + !! Function to get a list of all terminations in the system + implicit none + + ! Arguments + type(term_arr_type), intent(in) :: term + !! Termination info + type(term_list_type), allocatable, dimension(:) :: list + !! List of terminations + + ! Local variables + integer :: i, j + !! Loop indices + integer :: itmp1, nlist, loc + !! Temporary indices + type(term_list_type) :: tmp_element + !! Temporary element for swapping + + + if(.not.allocated(term%arr(1)%ladder))then + nlist = term%nterm + allocate(list(nlist)) + list(:)%loc = term%arr(:)%hmin + do i = 1, term%nterm + list(i)%term = i + end do + else + nlist = term%nstep*term%nterm + allocate(list(nlist)) + itmp1 = 0 + do i = 1, term%nterm + do j = 1, term%nstep + itmp1=itmp1+1 + list(itmp1)%loc = term%arr(i)%hmin+term%arr(i)%ladder(j) + list(itmp1)%loc = list(itmp1)%loc - & + ceiling( list(itmp1)%loc - 1._real32 ) + list(itmp1)%term = i + end do + end do + end if + + !! sort the list now + do i = 1, nlist + loc = minloc(list(i:nlist)%loc,dim=1) + i - 1 + tmp_element = list(i) + list(i) = list(loc) + list(loc) = tmp_element + end do + + end function get_term_list +!############################################################################### + + +!############################################################################### + subroutine set_layer_tol(term) + !! Set the tolerance for the layer definitions + implicit none + + ! Arguments + type(term_arr_type), intent(inout) :: term + !! Termination info + + ! Local variables + integer :: i + !! Loop index + real(real32) :: rtmp1 + !! Temporary variable for tolerance + + + do i = 1, term%nterm + if(i.eq.1)then + rtmp1 = abs(term%arr(i)%hmin - & + (term%arr(term%nterm)%hmax+term%arr(i)%ladder(term%nstep)-1._real32)& + )/4._real32 + else + rtmp1 = abs(term%arr(i)%hmin-term%arr(i-1)%hmax)/4._real32 + end if + if(rtmp1.lt.term%tol)then + term%tol = rtmp1 + end if + end do + + ! add the tolerances to the edges of the layers + ! this ensures that all atoms in the layers are captured + term%arr(:)%hmin = term%arr(:)%hmin - term%tol + term%arr(:)%hmax = term%arr(:)%hmax + term%tol + + end subroutine set_layer_tol +!############################################################################### + + +!############################################################################### + subroutine build_slab_supercell( basis, map, term, surf, & + height, num_layers, thickness, num_cells, & + term_start, term_end, term_step & + ) + !! Extend the basis to the maximum required height for all terminations + !! + !! This procedure extends the basis to form a supercell of the required + !! integer extension along the surface normal vector. This supercell is + !! sufficiently large to be able to be cut down to all required + !! terminations. + implicit none + + ! Arguments + type(basis_type), intent(inout) :: basis + !! Basis to be extended + integer, allocatable, dimension(:,:,:), intent(inout) :: map + !! Map from the original basis to the extended basis + type(term_arr_type), intent(inout) :: term + !! List of termination information + integer, dimension(2), intent(in) :: surf + !! Surface termination indices (for a single slab with both surface indices) + real(real32), intent(in) :: thickness + !! Requested thickness of the slab (mutually exclusive with num_layers) + integer, intent(in) :: num_layers + !! Requested number of layers in the slab (mutually exclusive with thickness) + real(real32), intent(out) :: height + !! Height of the slab if user-defined surf + integer, intent(out) :: num_cells + !! Maximum number of cells in the output basis + integer, intent(out) :: term_start, term_end, term_step + !! Termination indices for the slab + + ! Local variables + integer :: i, itmp1, icell, istep, iterm + !! Loop indices + real(real32) :: rtmp1, slab_thickness, largest_sep, layer_thickness + !! Temporary variables + character(1024) :: msg + !! Temporary message string + real(real32), dimension(3,3) :: tfmat + !! Transformation matrix + real(real32), allocatable, dimension(:) :: vtmp1 + !! Temporary vector + type(term_list_type), allocatable, dimension(:) :: list + !! List of terminations + logical :: success + !! Success flag for finding the required thickness + logical :: ludef_surf + !! Boolean whether surface terminations are user-defined + + + !--------------------------------------------------------------------------- + ! Initialise variables + !--------------------------------------------------------------------------- + height = 0._real32 + + + !--------------------------------------------------------------------------- + ! Define height of slab from user-defined values + !--------------------------------------------------------------------------- + ludef_surf = .false. + term_start = 1 + term_end = term%nterm + if(all(surf.ne.0))then + if(any(surf.gt.term%nterm))then + write(msg, '("INVALID SURFACE VALUES!\nOne or more value & + &exceeds the maximum number of terminations in the & + &structure.\n& + & Supplied values: ",I0,1X,I0,"\n& + & Maximum allowed: ",I0)') surf, term%nterm + call err_abort(trim(msg),fmtd=.true.) + end if + ludef_surf = .true. + list = get_term_list(term) + ! set term_start to first surface value + term_start = surf(1) + ! set term_end to first surface value as a user-defined surface ... + ! ... should not be cycled over. + ! it is just one, potentially assymetric, slab to be explored. + term_end = surf(1) + + ! determines the maximum number of cells required + allocate(vtmp1(size(list))) + height = term%arr(term_start)%hmin + do i=num_layers,2,-1 + vtmp1 = list(:)%loc - height + vtmp1 = vtmp1 - ceiling( vtmp1 - 1._real32 ) + itmp1 = minloc( vtmp1(:), dim=1,& + mask=& + vtmp1(:).gt.0.and.& + list(:)%term.eq.surf(1)) + height = height + vtmp1(itmp1) + end do + vtmp1 = list(:)%loc - height + where(vtmp1.lt.-1.E-5_real32) + vtmp1 = vtmp1 - ceiling( vtmp1 + 1.E-5_real32 - 1._real32 ) + end where + itmp1 = minloc( vtmp1(:), dim=1,& + mask=& + vtmp1(:).ge.-1.E-5_real32.and.& + list(:)%term.eq.surf(2)) + height = height + vtmp1(itmp1) - term%arr(term_start)%hmin + + ! get thickness of top/surface layer + rtmp1 = term%arr(surf(2))%hmax - term%arr(surf(2))%hmin + if(rtmp1.lt.-1.E-5_real32) rtmp1 = rtmp1 + 1._real32 + height = height + rtmp1 + + num_cells = ceiling(height) + height = height/real(num_cells,real32) + end if + + + !--------------------------------------------------------------------------- + ! Define termination iteration counter + !--------------------------------------------------------------------------- + if(term_end.lt.term_start)then + term_step = -1 + else + term_step = 1 + end if + + + !--------------------------------------------------------------------------- + ! Extend slab to user-defined thickness + !--------------------------------------------------------------------------- + if(.not.ludef_surf) num_cells = int((num_layers-1)/term%nstep)+1 + ! convert thickness, in angstroms, to number of cells + if(thickness.gt.0._real32)then + select case(term%axis) + case(1) + slab_thickness = abs( dot_product(uvec(cross([ basis%lat(2,:) ], [ basis%lat(3,:) ])), [ basis%lat(1,:) ]) ) + case(2) + slab_thickness = abs( dot_product(uvec(cross([ basis%lat(1,:) ], [ basis%lat(3,:) ])), [ basis%lat(2,:) ]) ) + case(3) + slab_thickness = abs( dot_product(uvec(cross([ basis%lat(1,:) ], [ basis%lat(2,:) ])), [ basis%lat(3,:) ]) ) + case default + write(msg, '("INVALID SURFACE AXIS!")') + call stop_program(trim(msg)) + return + end select + ! get the largest separation between two terminations + if(ludef_surf)then + + height = 0.E0 + largest_sep = abs( term%arr(surf(1))%hmin - & + term%arr(surf(2))%ladder(term%nstep) - & + term%arr(surf(2))%hmax + 1._real32 ) + if(largest_sep.lt.0._real32) largest_sep = 1._real32 + largest_sep + ! check for all terminations that a certain step is sufficiently large to reproduce thickness + cell_loop1: do icell = 0, ceiling(thickness/slab_thickness), 1 + layer_thickness = term%arr(surf(2))%hmax - term%arr(surf(1))%hmin - 2.E0 * term%tol + success = .false. + step_loop1: do istep = 1, term%nstep, 1 + if(surf(2).lt.surf(1))then + if(istep.eq.term%nstep)then + layer_thickness = & + term%arr(surf(2))%hmax - term%arr(surf(1))%hmin - & + 2.E0 * term%tol + ( & + 1.E0 + term%arr(surf(2))%ladder(1) - & + term%arr(surf(1))%ladder(term%nstep) & + ) + else + layer_thickness = & + term%arr(surf(2))%hmax - term%arr(surf(1))%hmin - & + 2.E0 * term%tol + ( & + term%arr(surf(2))%ladder(istep+1) - & + term%arr(surf(1))%ladder(istep) & + ) + end if + end if + rtmp1 = & + ( & + icell + layer_thickness + & + term%arr(surf(2))%ladder(istep) - & + term%arr(surf(1))%ladder(1) & + ) * slab_thickness + if(rtmp1.ge.thickness)then + success = .true. + height = rtmp1 + 2.E0 * term%tol * slab_thickness + exit step_loop1 + end if + end do step_loop1 + if(.not.success) cycle cell_loop1 + num_cells = icell + 1 + exit cell_loop1 + end do cell_loop1 + + else + largest_sep = abs( term%arr(1)%hmin - & + term%arr(1)%ladder(term%nstep) - & + term%arr(1)%hmax + 1._real32 ) + if(largest_sep.lt.0._real32) largest_sep = 1._real32 + largest_sep + ! check for all terminations that a certain step is sufficiently large to reproduce thickness + cell_loop2: do icell = 0, ceiling(thickness/slab_thickness), 1 + term_loop: do iterm = 1, term%nterm, 1 + layer_thickness = term%arr(iterm)%hmax - term%arr(iterm)%hmin - 2.E0 * term%tol + success = .false. + step_loop: do istep = 1, term%nstep, 1 + rtmp1 = ( icell + layer_thickness + term%arr(iterm)%ladder(istep) ) * slab_thickness + if(rtmp1.ge.thickness)then + success = .true. + exit step_loop + end if + end do step_loop + if(.not.success) cycle cell_loop2 + end do term_loop + num_cells = icell + 1 + exit cell_loop2 + end do cell_loop2 + + end if + height = height/real(num_cells * slab_thickness,real32) + end if + tfmat(:,:) = 0._real32 + tfmat(1,1) = 1._real32 + tfmat(2,2) = 1._real32 + tfmat(3,3) = num_cells + call transformer(basis,tfmat,map) + + + !--------------------------------------------------------------------------- + ! Readjust termination plane locations + ! ... i.e. divide all termination values by the number of cells + !--------------------------------------------------------------------------- + term%arr(:)%hmin = term%arr(:)%hmin/real(num_cells,real32) + term%arr(:)%hmax = term%arr(:)%hmax/real(num_cells,real32) + term%tol = term%tol/real(num_cells,real32) + + + end subroutine build_slab_supercell +!############################################################################### + + + +!############################################################################### + subroutine cut_slab_to_height( & + basis, map, term, surf, thickness, num_cells, num_layers, & + height, prefix, lcycle, & + orthogonalise, vacuum & + ) + !! Build a slab of the specified terminations + !! + !! This procedure builds a slab of the specified terminations from a + !! supplied supercell. The supercell must be large enough to be able to + !! be cut down to the required slab size. The supercell is built by + !! build_slab_supercell. + implicit none + + ! Arguments + type(basis_type), intent(inout) :: basis + !! Basis to be extended + integer, allocatable, dimension(:,:,:), intent(inout) :: map + !! Map from the original basis to the extended basis + type(term_arr_type), intent(in) :: term + !! Termination info + integer, dimension(2), intent(in) :: surf + !! Surface termination indices (for a single slab with both surface indices) + + real(real32), intent(in) :: thickness + !! Requested thickness of the slab (mutually exclusive with num_layers) + integer, intent(in) :: num_layers + !! Requested number of layers in the slab (mutually exclusive with thickness) + integer, intent(in) :: num_cells + !! Number of cells in the input slab + real(real32), intent(in) :: height + !! Height of the slab if user-defined surf (calculated in build_slab_supercell) + character(2), intent(in) :: prefix + !! Prefix for file names + !! (e.g. "lw" for lower, "up" for upper) + logical, intent(out) :: lcycle + !! Boolean whether to skip this slab in the cycle + logical, optional, intent(in) :: orthogonalise + !! Boolean whether to orthogonalise the slab (default: .true.) + real(real32), intent(in) :: vacuum + !! Vacuum thickness to add to the slab + + ! Local variables + integer :: term_btm_idx, term_top_idx + !! Indices of the bottom and top terminations + logical :: equivalent_surfaces + !! Boolean whether the two surfaces are equivalent + integer :: j, j_start, istep, icell + !! Loop index and termination step + integer :: natom_check + !! Check for number of atoms + integer :: num_cells_minus1 + !! Number of cells minus 1 + real(real32) :: rtmp1, slab_thickness, shift_val + !! Temporary variable for slab thickness and shifting + real(real32) :: layer_thickness, ladder_adjust + !! Layer thickness and ladder adjustment + character(2) :: prefix_ + !! Prefix for file names + character(5) :: slab_name + !! Name of the slab + character(1024) :: msg + !! Printing message + logical :: orthogonalise_ + !! Boolean whether to orthogonalise the slab + integer, dimension(3) :: abc + real(real32), dimension(3) :: surface_normal_vec + !! Surface normal vector + real(real32), dimension(3,3) :: tfmat + !! Transformation matrix + integer, allocatable, dimension(:) :: iterm_list + !! List of terminations + + + !--------------------------------------------------------------------------- + ! Initialise variables + !--------------------------------------------------------------------------- + abc = [ 1, 2, 3 ] + prefix_=to_lower(prefix) + if(prefix_.eq."lw") slab_name="LOWER" + if(prefix_.eq."up") slab_name="UPPER" + lcycle = .false. + rtmp1=0._real32 + tfmat=0._real32 + term_btm_idx = surf(1) + if(surf(2).gt.0)then + term_top_idx = surf(2) + else + term_top_idx = surf(1) + end if + equivalent_surfaces = .false. + if(term_btm_idx.eq.term_top_idx) equivalent_surfaces = .true. + select case(term%axis) + case(1) + surface_normal_vec = uvec(cross( [ basis%lat(2,:) ], [ basis%lat(3,:) ])) + slab_thickness = abs( dot_product(surface_normal_vec, [ basis%lat(1,:) ]) ) + case(2) + surface_normal_vec = uvec(cross( [ basis%lat(1,:) ], [ basis%lat(3,:) ])) + slab_thickness = abs( dot_product(surface_normal_vec, [ basis%lat(2,:) ]) ) + case(3) + surface_normal_vec = uvec(cross( [ basis%lat(1,:) ], [ basis%lat(2,:)] )) + slab_thickness = abs( dot_product(surface_normal_vec, [ basis%lat(3,:) ]) ) + case default + write(msg, '("INVALID SURFACE AXIS!")') + call stop_program(trim(msg)) + return + end select + if(thickness.gt.0._real32)then + rtmp1 = slab_thickness / num_cells * ( num_cells - 1 ) + istep = term%nstep + num_cells_minus1 = num_cells - 1 + cell_loop: do icell = 0, num_cells, 1 + layer_thickness = term%arr(term_top_idx)%hmax - term%arr(term_btm_idx)%hmin - 2.E0 * term%tol + ladder_adjust = 0._real32 + step_loop: do j = 1, term%nstep + if(term_top_idx.lt.term_btm_idx)then + if(j.eq.term%nstep)then + layer_thickness = term%arr(term_top_idx)%hmax - term%arr(term_btm_idx)%hmin - 2.E0 * term%tol + ladder_adjust = 1.E0 + term%arr(term_top_idx)%ladder(1) - term%arr(term_btm_idx)%ladder(term%nstep) + else + layer_thickness = term%arr(term_top_idx)%hmax - term%arr(term_btm_idx)%hmin - 2.E0 * term%tol + ladder_adjust = term%arr(term_top_idx)%ladder(j+1) - term%arr(term_btm_idx)%ladder(j) + end if + end if + rtmp1 = & + ( & + icell / real(num_cells,real32) + layer_thickness & + ) * slab_thickness + & + ( & + ladder_adjust + term%arr(term_top_idx)%ladder(j) - & + term%arr(term_btm_idx)%ladder(1) & + ) * slab_thickness / real(num_cells,real32) + if(rtmp1.ge.thickness)then + istep = j + num_cells_minus1 = icell + exit cell_loop + end if + end do step_loop + end do cell_loop + else + istep = num_layers - (num_cells-1)*term%nstep + num_cells_minus1 = num_cells - 1 + end if + natom_check = basis%natom + + orthogonalise_ = .true. + if(present(orthogonalise)) orthogonalise_ = orthogonalise + + + !--------------------------------------------------------------------------- + ! Set up list for checking expected number of atoms + !--------------------------------------------------------------------------- + allocate(iterm_list(term%nterm)) + do j = 1, term%nterm + iterm_list(j) = j + end do + iterm_list = cshift( iterm_list, term_btm_idx - 1 ) + if(.not.equivalent_surfaces)then + j_start = term_top_idx - term_btm_idx + 1 + if(j_start.le.0) j_start = j_start + term%nterm + j_start = j_start + 1 + else + j_start = 2 + end if + + + !--------------------------------------------------------------------------- + ! Shift lower material to specified termination + !--------------------------------------------------------------------------- + call shifter(basis,term%axis,-term%arr(term_btm_idx)%hmin,.true.) + + + !--------------------------------------------------------------------------- + ! Determine cell reduction to specified termination + !--------------------------------------------------------------------------- + do j = 1, 3 + tfmat(j,j) = 1._real32 + if(j.eq.term%axis)then + if(.not.equivalent_surfaces)then + tfmat(j,j) = height + else + if(istep.ne.0)then + rtmp1 = num_cells_minus1 + term%arr(term_btm_idx)%ladder(istep) + rtmp1 = rtmp1/real(num_cells, real32) + tfmat(j,j) = rtmp1 + & + (term%arr(term_btm_idx)%hmax - term%arr(term_btm_idx)%hmin) + end if + end if + end if + end do + + + !--------------------------------------------------------------------------- + ! Check number of atoms is expected + !--------------------------------------------------------------------------- + if(num_cells_minus1.ne.num_cells-1)then + do icell = num_cells_minus1 + 2, num_cells, 1 + natom_check = natom_check - nint( basis%natom / real(num_cells) ) + end do + end if + + + !--------------------------------------------------------------------------- + ! Apply transformation and shift cell back to bottom of layer + ! ... i.e. account for the tolerance that has been added to layer ... + ! ... hmin and hmax + !--------------------------------------------------------------------------- + shift_val = term%tol * slab_thickness / modu(basis%lat(term%axis,:)) + call transformer(basis,tfmat,map) + call shifter(basis,term%axis,-shift_val/tfmat(term%axis,term%axis),.true.) + + + !--------------------------------------------------------------------------- + ! Check number of atoms is expected + !--------------------------------------------------------------------------- + if(term%nterm.gt.1.or.term%nstep.gt.1)then + do j = 1, max(0,term%nstep-istep), 1 + natom_check = natom_check - sum(term%arr(:)%natom) + end do + do j = j_start, term%nterm, 1 + natom_check = natom_check - term%arr(iterm_list(j))%natom + end do + end if + if(basis%natom.ne.natom_check)then + write(msg, '("NUMBER OF ATOMS IN '//to_upper(slab_name)//' SLAB! & + &Expected ",I0," but generated ",I0," instead")') & + natom_check,basis%natom + if(tfmat(term%axis,term%axis).gt.1._real32)then + write(0,'("THE TRANSFORMATION IS GREATER THAN ONE ",F0.9)') & + tfmat(term%axis,term%axis) + end if + call err_abort_print_struc(basis,prefix_//"_term.vasp",& + trim(msg),.true.) + lcycle = .true. + end if + + + !--------------------------------------------------------------------------- + ! Apply slab_cuber to orthogonalise lower material + !--------------------------------------------------------------------------- + call basis%normalise(ceil_val=0.9999_real32,floor_coords=.true.,zero_round=0._real32) + call set_vacuum(basis,term%axis,1._real32-term%tol/tfmat(term%axis,term%axis),vacuum) + abc=cshift(abc,3-term%axis) + if(orthogonalise_)then + ortho_check: do j=1,2 + if(abs(dot_product(basis%lat(abc(j),:),basis%lat(term%axis,:))).gt.1.E-5_real32)then + call ortho_axis(basis,term%axis) + exit ortho_check + end if + end do ortho_check + end if + call basis%normalise(ceil_val=0.9999_real32,floor_coords=.true.,zero_round=0._real32) + + + end subroutine cut_slab_to_height +!############################################################################### + +end module artemis__terminations diff --git a/src/interfaces.f90 b/src/interfaces.f90 deleted file mode 100644 index 4d2cc7b..0000000 --- a/src/interfaces.f90 +++ /dev/null @@ -1,1586 +0,0 @@ -!!!############################################################################# -!!! INTERFACES CARD SUBROUTINES -!!! Code written by Ned Thaddeus Taylor and Isiah Edward Mikel Rudkin -!!! Code part of the ARTEMIS group (Hepplestone research group). -!!! Think Hepplestone, think HRG. -!!!############################################################################# -module interface_subroutines - use io - use misc_linalg, only: uvec,modu,get_area,inverse - use inputs - use interface_identifier, only: intf_info_type,& - get_interface,get_layered_axis,gen_DON - use edit_geom, only: planecutter,primitive_lat,ortho_axis,& - shift_region,set_vacuum,transformer,shifter,reducer,& - get_min_bulk_bond,get_min_bond,& - clone_bas,bas_lat_merge,get_shortest_bond,bond_type,& - share_strain, normalise_basis, MATNORM - use mod_sym, only: term_arr_type,confine_type,gldfnd,& - get_terminations,get_primitive_cell - use swapping, only: rand_swapper - use shifting !!! CHANGE TO SHIFTER? - implicit none - integer, private :: intf=0 - double precision, private, parameter :: tmp_vac = 14.D0 - - - type term_list_type - integer :: term - double precision :: loc - end type term_list_type - private :: term_list_type - - type(bulk_DON_type), dimension(2) :: bulk_DON - - -!!!updated 2023/02/16 - - -contains -!!!############################################################################# -!!! Generates and prints terminations parallel to the supplied miller plane -!!!############################################################################# - subroutine gen_terminations(lat,bas,miller_plane,axis,directory,& - thickness,udef_layer_sep) - implicit none - integer :: unit - integer :: itmp1,iterm,term_start,term_end,iterm_step - integer :: old_natom,ncells,thickness_val,ntrans - double precision :: height - character(len=1024) :: dirname,filename,pwd - logical :: ludef_surf,lignore - type(bas_type) :: tmp_bas1,tmp_bas2 - type(confine_type) :: confine - type(term_arr_type) :: term - double precision, dimension(3,3) :: tfmat,tmp_lat1,tmp_lat2 - - integer, allocatable, dimension(:,:,:) :: bas_map,t1bas_map - double precision, allocatable, dimension(:,:) :: trans - - integer, intent(in) :: axis - type(bas_type), intent(in) :: bas - integer, dimension(3), intent(in) :: miller_plane - double precision, dimension(3,3), intent(in) :: lat - - integer, optional, intent(in) :: thickness - double precision, optional, intent(in) :: udef_layer_sep - character(len=*), optional, intent(in) :: directory - - - !! copy lattice and basis for manipulating - call clone_bas(bas,tmp_bas1,lat,tmp_lat1) - allocate(bas_map(tmp_bas1%nspec,maxval(tmp_bas1%spec(:)%num,dim=1),2)) - bas_map=-1 - - - write(6,'(1X,"Using supplied plane...")') - tfmat=planecutter(tmp_lat1,dble(miller_plane)) - call transformer(tmp_lat1,tmp_bas1,tfmat,bas_map) - !call err_abort_print_struc(lat,bas,"check.vasp","stop") - - !!----------------------------------------------------------------------- - !! Finds smallest thickness of the slab and increases to ... - !! ... user-defined thickness - !!----------------------------------------------------------------------- - confine%l=.false. - confine%axis=axis - confine%laxis=.false. - confine%laxis(axis)=.true. - old_natom=tmp_bas1%natom - if(allocated(trans)) deallocate(trans) - allocate(trans(minval(tmp_bas1%spec(:)%num+2),3)) - call gldfnd(confine,tmp_bas1,tmp_bas1,trans,ntrans) - tfmat(:,:)=0.D0 - tfmat(1,1)=1.D0 - tfmat(2,2)=1.D0 - if(ntrans.eq.0)then - tfmat(3,3)=1.D0 - else - itmp1=minloc(abs(trans(:ntrans,axis)),dim=1,& - mask=abs(trans(:ntrans,axis)).gt.1.D-3/modu(tmp_lat1(axis,:))) - tfmat(3,:)=trans(itmp1,:) - end if - if(all(abs(tfmat(3,:)).lt.1.D-5)) tfmat(3,3) = 1.D0 - call transformer(tmp_lat1,tmp_bas1,tfmat,bas_map) - - !! get the terminations - if(present(udef_layer_sep)) then - term = get_terminations(tmp_lat1,tmp_bas1,axis,& - lprint=.true.,layer_sep=udef_layer_sep) - else - term = get_terminations(tmp_lat1,tmp_bas1,axis,& - lprint=.true.,layer_sep=layer_sep) - end if - - !! set thickness if provided by user - if(present(thickness))then - thickness_val = thickness - else - thickness_val = 1 - end if - - !! make directory and change to that directory - if(present(directory))then - dirname = directory - else - dirname = "DTERMINATIONS" - end if - call system('mkdir -p '//trim(adjustl(dirname))) - call getcwd(pwd) - call chdir(dirname) - - !! determine tolerance for layer separations (termination tolerance) - !! ... this is different from layer_sep - call set_layer_tol(term) - - !! determine required extension and perform that - call set_slab_height(tmp_lat1,tmp_bas1,bas_map,term,lw_surf,old_natom,& - height,thickness_val,ncells,& - term_start,term_end,iterm_step,ludef_surf,& - dirname,"lw",lignore) - - - !!-------------------------------------------------------------------------- - !! Normalise lattice - !!-------------------------------------------------------------------------- - if(lnorm_lat)then - call reducer(tmp_lat1,tmp_bas1) - tmp_lat1=MATNORM(tmp_lat1) - end if - - - !!-------------------------------------------------------------------------- - !! loop over terminations and write them - !!-------------------------------------------------------------------------- - do iterm=term_start,term_end,iterm_step - call clone_bas(tmp_bas1,tmp_bas2,tmp_lat1,tmp_lat2) - if(allocated(t1bas_map)) deallocate(t1bas_map) - allocate(t1bas_map,source=bas_map) - call prepare_slab(tmp_lat2,tmp_bas2,bas_map,term,iterm,& - thickness_val,ncells,height,ludef_surf,lw_surf(2),& - "lw",lignore,lortho,vacuum) - - - !!----------------------------------------------------------------------- - !! Print structure - !!----------------------------------------------------------------------- - unit=100+iterm - write(filename,'("POSCAR_term",I0)') iterm - open(unit,file=trim(filename)) - call geom_write(unit,tmp_lat2,tmp_bas2) - close(unit) - end do - - !! return to parent directory - call chdir(pwd) - - - return - end subroutine gen_terminations -!!!############################################################################# - - -!!!############################################################################# -!!! generate interfaces -!!!############################################################################# - subroutine gen_interfaces_restart(lat,bas) - implicit none - integer :: is,ia,js,ja - double precision :: dtmp1,min_bond,min_bond1,min_bond2 - type(bas_type) :: bas - type(intf_info_type) :: intf - double precision, dimension(3) :: vtmp1 - double precision, dimension(3,3) :: lat - - - call system('mkdir -p '//trim(adjustl(dirname))) - call chdir(dirname) - - min_bond1=huge(0.D0) - min_bond2=huge(0.D0) - if(any(udef_intf_loc.lt.0.D0))then - if(ludef_axis)then - intf=get_interface(lat,bas,axis) - else - intf=get_interface(lat,bas) - end if - intf%loc=intf%loc/modu(lat(intf%axis,:)) - write(6,*) "interface axis:",intf%axis - write(6,*) "interface loc:",intf%loc - !! write interface location to a file for user to refer back to - open(unit=10,file="interface_location.dat") - write(10,'(1X,"AXIS = ",I0)') intf%axis - write(10,'(1X,"INTF_LOC = ",2(2X,F9.6))') intf%loc - close(10) - else - intf%axis = axis - intf%loc = udef_intf_loc - end if - specloop1: do is=1,bas%nspec - atomloop1: do ia=1,bas%spec(is)%num - - specloop2: do js=1,bas%nspec - atomloop2: do ja=1,bas%spec(js)%num - if(is.eq.js.and.ia.eq.ja) cycle atomloop2 - if( & - ( bas%spec(is)%atom(ia,intf%axis).gt.intf%loc(1).and.& - bas%spec(is)%atom(ia,intf%axis).lt.intf%loc(2) ).and.& - ( bas%spec(js)%atom(ja,intf%axis).gt.intf%loc(1).and.& - bas%spec(js)%atom(ja,intf%axis).lt.intf%loc(2) ) )then - vtmp1 = (bas%spec(is)%atom(ia,:3)-bas%spec(js)%atom(ja,:3)) - vtmp1 = matmul(vtmp1,lat) - dtmp1 = modu(vtmp1) - if(dtmp1.lt.min_bond1) min_bond1 = dtmp1 - elseif( & - ( bas%spec(is)%atom(ia,intf%axis).lt.intf%loc(1).or.& - bas%spec(is)%atom(ia,intf%axis).gt.intf%loc(2) ).and.& - ( bas%spec(js)%atom(ja,intf%axis).lt.intf%loc(1).or.& - bas%spec(js)%atom(ja,intf%axis).gt.intf%loc(2) ) )then - vtmp1 = (bas%spec(is)%atom(ia,:3)-bas%spec(js)%atom(ja,:3)) - vtmp1 = matmul(vtmp1,lat) - dtmp1 = modu(vtmp1) - if(dtmp1.lt.min_bond2) min_bond2 = dtmp1 - end if - - end do atomloop2 - end do specloop2 - - end do atomloop1 - end do specloop1 - - min_bond = ( min_bond1 + min_bond2 )/2.D0 - write(6,'(1X,"Avg min bulk bond: ",F0.3," Å")') min_bond - write(6,'(1X,"Trans-interfacial scaling factor:",F0.3)') c_scale - call gen_shifts_and_swaps(lat,bas,intf%axis,intf%loc,min_bond,& - ishift,nshift,& - iswap,swap_den,nswap) - - - end subroutine gen_interfaces_restart -!!!############################################################################# - - -!!!############################################################################# -!!! generate interfaces -!!!############################################################################# - subroutine gen_interfaces(tolerance,inlw_lat,inup_lat,inlw_bas,inup_bas) - implicit none - integer :: j,iterm,jterm,ntrans,ifit,iunique,old_natom,itmp1,old_intf - integer :: is, ia - integer :: iterm_step,jterm_step - integer :: lw_ncells,up_ncells - integer :: lw_layered_axis,up_layered_axis - integer :: intf_start,intf_end - integer :: lw_term_start,lw_term_end,up_term_start,up_term_end - double precision :: avg_min_bond - double precision :: lw_height,up_height - double precision :: dtmp1,bondlength - character(3) :: abc - character(1024) :: pwd,intf_dir,dirpath,msg, filename - logical :: ludef_lw_surf,ludef_up_surf,lcycle - type(bas_type) :: sbas - type(bas_type) :: inlw_bas,inup_bas - type(bas_type) :: lw_bas,up_bas,tlw_bas,tup_bas - type(tol_type) :: tolerance - type(confine_type) :: confine - type(latmatch_type) :: SAV - type(term_arr_type) :: lw_term,up_term - integer, dimension(3) :: ivtmp1 - double precision, dimension(2) :: intf_loc - double precision, dimension(3) :: init_offset=[0.D0,0.D0,2.D0] - !double precision, dimension(3,3) :: mtmp1,DONup_lat - double precision, dimension(3,3) :: tfmat,slat,inlw_lat,inup_lat - double precision, dimension(3,3) :: lw_lat,up_lat,tlw_lat,tup_lat - integer, allocatable, dimension(:,:,:) :: lw_map,t1lw_map,t2lw_map - integer, allocatable, dimension(:,:,:) :: up_map,t1up_map,t2up_map - double precision, allocatable, dimension(:,:) :: trans - - -!!!----------------------------------------------------------------------------- -!!! determines the primitive and niggli reduced cell for each bulk -!!!----------------------------------------------------------------------------- - write(6,*) - if(lw_use_pricel)then - write(6,'(1X,"Using primitive cell for lower material")') - call get_primitive_cell(inlw_lat,inlw_bas) - else - write(6,'(1X,"Using supplied cell for lower material")') - call reducer(inlw_lat,inlw_bas) - inlw_lat=primitive_lat(inlw_lat) - end if - if(up_use_pricel)then - write(6,'(1X,"Using primitive cell for upper material")') - call get_primitive_cell(inup_lat,inup_bas) - else - write(6,'(1X,"Using supplied cell for upper material")') - call reducer(inup_lat,inup_bas) - inup_lat=primitive_lat(inup_lat) - end if - write(6,*) - - - -!!!----------------------------------------------------------------------------- -!!! investigates individual bulks and their bondlengths -!!!----------------------------------------------------------------------------- - avg_min_bond = & - ( get_min_bulk_bond(inlw_lat,inlw_bas) + & - get_min_bulk_bond(inup_lat,inup_bas) )/2.D0 - write(6,'(1X,"Avg min bulk bond: ",F0.3," Å")') avg_min_bond - write(6,'(1X,"Trans-interfacial scaling factor: ",F0.3)') c_scale - if(ishift.eq.-1) nshift=1 - - -!!!----------------------------------------------------------------------------- -!!! gets bulk DONs, if ISHIFT = 4 -!!!----------------------------------------------------------------------------- - allocate(lw_map(inlw_bas%nspec,maxval(inlw_bas%spec(:)%num,dim=1),2)) - allocate(up_map(inup_bas%nspec,maxval(inup_bas%spec(:)%num,dim=1),2)) - if(ishift.eq.4.or.ishift.eq.0)then - lw_map=0 - bulk_DON(1)%spec=gen_DON(inlw_lat,inlw_bas,& - dist_max=max_bondlength,& - scale_dist=.false.,& - norm=.true.) - do is = 1, inlw_bas%nspec - if(all(abs(bulk_DON(1)%spec(is)%atom(:,:)).lt.1.D0))then - bondlength = huge(0.D0) - do ia = 1, inlw_bas%spec(is)%num - dtmp1 = modu(get_min_bond(inlw_lat, inlw_bas, is, ia)) - if(dtmp1.lt.bondlength) bondlength = dtmp1 - if(dtmp1.gt.max_bondlength)then - write(filename,'("lw_DON_",I0,"_",I0,".dat")') is,ia - open(unit=13,file=filename) - do j=1,1000 - write(13,*) & - (j-1)*max_bondlength/1000,& - bulk_DON(1)%spec(is)%atom(ia,j) - end do - close(13) - end if - end do - if(bondlength.gt.max_bondlength)then - write(0,*) "Min bondlength for lower species ", & - is, " is ", bondlength - write(0,*) "To account for this, increase MBOND_MAXLEN to at & - &least ",bondlength - end if - call err_abort("ISSUE WITH THE LOWER BULK DON!!!") - end if - end do - up_map=0 - bulk_DON(2)%spec=gen_DON(inup_lat,inup_bas,& - dist_max=max_bondlength,& - scale_dist=.false.,& - norm=.true.) - do is = 1, inup_bas%nspec - if(all(abs(bulk_DON(2)%spec(is)%atom(:,:)).lt.1.D0))then - bondlength = huge(0.D0) - do ia = 1, inup_bas%spec(is)%num - dtmp1 = modu(get_min_bond(inup_lat, inup_bas, is, ia)) - if(dtmp1.lt.bondlength) bondlength = dtmp1 - if(dtmp1.gt.max_bondlength)then - write(filename,'("up_DON_",I0,"_",I0,".dat")') is,ia - open(unit=13,file=filename) - do j=1,1000 - write(13,*) & - (j-1)*max_bondlength/1000,& - bulk_DON(2)%spec(is)%atom(ia,j) - end do - close(13) - end if - end do - if(bondlength.gt.max_bondlength)then - write(0,*) "Min bondlength for upper species ", & - is, " is ", bondlength - write(0,*) "To account for this, increase MBOND_MAXLEN to at & - &least ",bondlength - end if - call err_abort("ISSUE WITH THE UPPER BULK DON!!!") - end if - end do - else - lw_map=-1 - up_map=-1 - end if - - -!!!----------------------------------------------------------------------------- -!!! checks whether system appears layered -!!!----------------------------------------------------------------------------- - lw_layered_axis=get_layered_axis(inlw_lat,inlw_bas) - if(.not.lw_layered.and.lw_layered_axis.gt.0)then - ivtmp1=0 - ivtmp1(lw_layered_axis)=1 - if(ludef_lw_layered)then - write(msg,'("Lower crystal appears layered along axis ",I0,"\n& - &Partial layer terminations will be generated\n& - &We suggest using LW_MILLER =",3(1X,I1))') lw_layered_axis,ivtmp1 - call print_warning(trim(msg)) - else - write(msg,'("Lower crystal has been identified as layered\nalong",3(1X,I1),"\n& - &Confining crystal to this plane and\nstoichiometric terminations.\n& - &If you don''t want this, set\nLW_LAYERED = .FALSE.")') & - ivtmp1 - call print_warning(trim(msg)) - lw_mplane=ivtmp1 - lw_layered=.true. - end if - elseif(lw_layered.and.lw_layered_axis.gt.0.and.all(lw_mplane.eq.0))then - lw_mplane(lw_layered_axis)=1 - end if - - up_layered_axis=get_layered_axis(inup_lat,inup_bas) - if(.not.up_layered.and.up_layered_axis.gt.0)then - ivtmp1=0 - ivtmp1(up_layered_axis)=1 - if(ludef_up_layered)then - write(msg,'("Upper crystal appears layered along axis ",I0,"\n& - &Partial layer terminations will be generated\n& - &We suggest using UP_MILLER =",3(1X,I1))') up_layered_axis,ivtmp1 - call print_warning(trim(msg)) - else - write(msg,'("Upper crystal has been identified as layered\nalong",3(1X,I1),"\n& - &Confining crystal to this plane and\nstoichiometric terminations.\n& - &If you don''t want this, set\nUP_LAYERED = .FALSE.")') & - ivtmp1 - call print_warning(trim(msg)) - up_mplane=ivtmp1 - up_layered=.true. - end if - elseif(up_layered.and.up_layered_axis.gt.0.and.all(up_mplane.eq.0))then - up_mplane(up_layered_axis)=1 - end if - - -!!!----------------------------------------------------------------------------- -!!! Finds and stores the best matches between the materials -!!!----------------------------------------------------------------------------- - call getcwd(pwd) - old_intf = -1 - intf=0 - abc="abc" - if(imatch.ne.0.and.(any(lw_mplane.ne.0).or.any(up_mplane.ne.0)))then - call err_abort( '& - &Cannot use LW_MILLER or UP_MILLER with IMATCH>0\n& - Exiting...', & - fmtd=.true. & - ) - elseif(imatch.ne.0)then - write(msg,'("& - &IMATCH /= 0 methods are experimental and may\n& - ¬ work as expected.\n& - &They are not intended to be thorough searches.\n& - &This method is not recommended unless you\n& - &are clear on its intended use and\n& - &limitations.& - &")') - call print_warning(trim(msg)) - end if - if(any(lw_mplane.ne.0))then - if(imatch.ne.0)then - abc="ab " - tfmat=planecutter(inlw_lat,dble(lw_mplane)) - call transformer(inlw_lat,inlw_bas,tfmat,lw_map) - SAV=get_best_match(& - tolerance,& - inlw_lat,inup_lat,& - inlw_bas,inup_bas,& - abc,"abc",lprint_matches,ierror,imatch=imatch) - elseif(any(up_mplane.ne.0))then - SAV=get_best_match(& - tolerance,& - inlw_lat,inup_lat,& - inlw_bas,inup_bas,& - abc,"abc",lprint_matches,ierror,imatch=imatch,& - plane1=lw_mplane,plane2=up_mplane,nmiller=nmiller) - else - SAV=get_best_match(& - tolerance,& - inlw_lat,inup_lat,& - inlw_bas,inup_bas,& - abc,"abc",lprint_matches,ierror,imatch=imatch,& - plane1=lw_mplane,nmiller=nmiller) - end if - elseif(any(up_mplane.ne.0))then - SAV=get_best_match(& - tolerance,& - inlw_lat,inup_lat,& - inlw_bas,inup_bas,& - abc,"abc",lprint_matches,ierror,imatch=imatch,& - plane2=up_mplane,nmiller=nmiller) - else - SAV=get_best_match(& - tolerance,& - inlw_lat,inup_lat,& - inlw_bas,inup_bas,& - abc,"abc",lprint_matches,ierror,imatch=imatch,& - nmiller=nmiller) - end if - if(min(tolerance%nstore,SAV%nfit).eq.0)then - write(0,'("No matches found.")') - write(0,'("Exiting...")') - call exit() - else - write(0,'(1X,"Number of matches found: ",I0)')& - min(tolerance%nstore,SAV%nfit) - end if - write(6,'(1X,"Maximum number of generated interfaces will be: ",I0)')& - nterm*nshift*tolerance%nstore - if(.not.lgen_interfaces)then - write(0,'(1X,"Told not to generate interfaces, just find matches.")') - write(0,'("Exiting...")') - call exit() - end if - - -!!!----------------------------------------------------------------------------- -!!! Saves current directory and moves to new directory -!!!----------------------------------------------------------------------------- - call system('mkdir -p '//trim(adjustl(dirname))) - call chdir(dirname) - call getcwd(intf_dir) - - if(iintf.gt.0)then - intf_start=iintf - intf_end=iintf - write(6,'(1X,"Generating only interfaces for match ",I0)') iintf - else - intf_start=1 - intf_end=min(tolerance%nstore,SAV%nfit) - end if - iunique=0 -!!!----------------------------------------------------------------------------- -!!! Applies the best match transformations -!!!----------------------------------------------------------------------------- - intf_loop: do ifit=intf_start,intf_end - write(6,'("Fit number: ",I0)') ifit - call clone_bas(inlw_bas,lw_bas,inlw_lat,lw_lat) - call clone_bas(inup_bas,up_bas,inup_lat,up_lat) - if(allocated(t1lw_map)) deallocate(t1lw_map) - if(allocated(t1up_map)) deallocate(t1up_map) - allocate(t1lw_map,source=lw_map) - allocate(t1up_map,source=up_map) - - - !!----------------------------------------------------------------------- - !! Applies the best match transformations - !!----------------------------------------------------------------------- - call transformer(lw_lat,lw_bas,dble(SAV%tf1(ifit,:,:)),t1lw_map) - call transformer(up_lat,up_bas,dble(SAV%tf2(ifit,:,:)),t1up_map) - - - !!----------------------------------------------------------------------- - !! Determines the cell change for the upper lattice to get the new DON - !!----------------------------------------------------------------------- - if(ishift.eq.4)then - !! Issue with using this method when large deformations result in large - !! angle changes. REMOVING IT FOR NOW AND RETURNING TO CALCULATING DONS - !! FOR THE SUPERCELL. - t1up_map=0 !TEMPORARY TO USE SUPERCELL DONS. - !do i=1,2 - ! mtmp1(i,:) = & - ! ( modu(lw_lat(i,:)) )*uvec(up_lat(i,:)) - !end do - !mtmp1(3,:) = up_lat(3,:) - !DONup_lat = matmul(mtmp1,inverse(dble(SAV%tf2(ifit,:,:)))) - !if(ierror.eq.1)then - ! write(0,*) "#####################################" - ! write(0,*) "ifit", ifit - ! write(0,*) "undeformed lattice" - ! write(0,'(3(2X,F6.2))') (mtmp1(i,:),i=1,3) - ! write(0,*) - ! write(0,*) "deformed lattice" - ! write(0,'(3(2X,F8.4))') (DONup_lat(i,:),i=1,3) - ! write(0,*) - !end if - deallocate(bulk_DON(2)%spec) - bulk_DON(2)%spec=gen_DON(up_lat,up_bas,& - dist_max=max_bondlength,& - scale_dist=.false.,& - norm=.true.) - !call err_abort_print_struc(DONup_lat,inup_bas,"bulk_up_term.vasp",& - ! "",.false.) - end if - - - !!----------------------------------------------------------------------- - !! Finds smallest thickness of the lower slab and increases to ... - !!user-defined thickness - !! SHOULD MAKE IT LATER MAKE DIFFERENT SETS OF THICKNESSES - !!----------------------------------------------------------------------- - confine%l=.false. - confine%axis=axis - confine%laxis=.false. - confine%laxis(axis)=.true. - old_natom=lw_bas%natom - if(allocated(trans)) deallocate(trans) - allocate(trans(minval(lw_bas%spec(:)%num+2),3)) - call gldfnd(confine,lw_bas,lw_bas,trans,ntrans) - tfmat(:,:)=0.D0 - tfmat(1,1)=1.D0 - tfmat(2,2)=1.D0 - if(ntrans.eq.0)then - tfmat(3,3)=1.D0 - else - itmp1=minloc(abs(trans(:ntrans,axis)),dim=1,& - mask=abs(trans(:ntrans,axis)).gt.1.D-3/modu(lw_lat(axis,:))) - tfmat(3,:)=trans(itmp1,:) - end if - if(all(abs(tfmat(3,:)).lt.1.D-5)) tfmat(3,3) = 1.D0 - call transformer(lw_lat,lw_bas,tfmat,t1lw_map) - - - !!----------------------------------------------------------------------- - !! Finds all terminations parallel to the surface plane - !!----------------------------------------------------------------------- - if(allocated(lw_term%arr)) deallocate(lw_term%arr) - lw_term=get_terminations(lw_lat,lw_bas,axis,& - lprint=lprint_terms,layer_sep=lw_layer_sep) - - - !!----------------------------------------------------------------------- - !! Sort out ladder rungs (checks whether the material is centrosymmetric) - !!----------------------------------------------------------------------- - !call setup_ladder(lw_lat,lw_bas,axis,lw_term) - if(sum(lw_term%arr(:)%natom)*lw_term%nstep.ne.lw_bas%natom)then - write(msg, '("ERROR: Number of atoms in lower layers not correct: "& - &I0,2X,I0)') sum(lw_term%arr(:)%natom)*lw_term%nstep,lw_bas%natom - call err_abort(trim(msg),fmtd=.true.) - end if - call set_layer_tol(lw_term) - - - !!----------------------------------------------------------------------- - !! Defines height of lower slab from user-defined values - !!----------------------------------------------------------------------- - call set_slab_height(lw_lat,lw_bas,t1lw_map,lw_term,lw_surf, old_natom,& - lw_height,lw_thickness,lw_ncells,& - lw_term_start,lw_term_end,iterm_step,ludef_lw_surf,& - intf_dir,"lw",lcycle) - if(lcycle) cycle intf_loop - - - !!----------------------------------------------------------------------- - !! Finds smallest thickness of the upper slab and increases to ... - !! ... user-defined thickness - !! SHOULD MAKE IT LATER MAKE DIFFERENT SETS OF THICKNESSES - !!----------------------------------------------------------------------- - old_natom=up_bas%natom - deallocate(trans) - allocate(trans(minval(up_bas%spec(:)%num+2),3)) - call gldfnd(confine,up_bas,up_bas,trans,ntrans) - tfmat(:,:)=0.D0 - tfmat(1,1)=1.D0 - tfmat(2,2)=1.D0 - if(ntrans.eq.0)then - tfmat(3,3)=1.D0 - else - itmp1=minloc(abs(trans(:ntrans,axis)),dim=1,& - mask=abs(trans(:ntrans,axis)).gt.1.D-3/modu(lw_lat(axis,:))) - tfmat(3,:)=trans(itmp1,:) - end if - if(all(abs(tfmat(3,:)).lt.1.D-5)) tfmat(3,3) = 1.D0 - call transformer(up_lat,up_bas,tfmat,t1up_map) - - - !!----------------------------------------------------------------------- - !! Finds all up_lat unique terminations parallel to the surface plane - !!----------------------------------------------------------------------- - if(allocated(up_term%arr)) deallocate(up_term%arr) - up_term=get_terminations(up_lat,up_bas,axis,& - lprint=lprint_terms,layer_sep=up_layer_sep) - - - !!----------------------------------------------------------------------- - !! Sort out ladder rungs (checks whether the material is centrosymmetric) - !!----------------------------------------------------------------------- - !call setup_ladder(up_lat,up_bas,axis,up_term) - if(sum(up_term%arr(:)%natom)*up_term%nstep.ne.up_bas%natom)then - write(msg, '("ERROR: Number of atoms in upper layers not correct: "& - &I0,2X,I0)') sum(up_term%arr(:)%natom)*up_term%nstep,up_bas%natom - call err_abort(trim(msg),fmtd=.true.) - end if - call set_layer_tol(up_term) - - - !!----------------------------------------------------------------------- - !! Defines height of upper slab from user-defined values - !!----------------------------------------------------------------------- - call set_slab_height(up_lat,up_bas,t1up_map,up_term,up_surf,old_natom,& - up_height,up_thickness,up_ncells,& - up_term_start,up_term_end,jterm_step,ludef_up_surf,& - intf_dir,"up",lcycle) - if(lcycle) cycle intf_loop - - - !!----------------------------------------------------------------------- - !! Print termination plane locations - !!----------------------------------------------------------------------- - write(6,'(1X,"Number of unique terminations: ",I0,2X,I0)') & - lw_term%nterm,up_term%nterm - - !!----------------------------------------------------------------------- - !! Cycle over terminations of both materials and generates interfaces ... - !! ... composed of all of the possible combinations of the two - !!----------------------------------------------------------------------- - lw_term_loop: do iterm=lw_term_start,lw_term_end,iterm_step - call clone_bas(lw_bas,tlw_bas,lw_lat,tlw_lat) - if(allocated(t2lw_map)) deallocate(t2lw_map) - allocate(t2lw_map,source=t1lw_map) - !!-------------------------------------------------------------------- - !! Shifts lower material to specified termination - !!-------------------------------------------------------------------- - call prepare_slab(tlw_lat,tlw_bas,t2lw_map,lw_term,iterm,& - lw_thickness,lw_ncells,lw_height,ludef_lw_surf,lw_surf(2),& - "lw",lcycle) - if(lcycle) cycle lw_term_loop - - - !!-------------------------------------------------------------------- - !! Cycles over terminations of upper material - !!-------------------------------------------------------------------- - up_term_loop: do jterm=up_term_start,up_term_end,jterm_step - call clone_bas(up_bas,tup_bas,up_lat,tup_lat) - if(allocated(t2up_map)) deallocate(t2up_map) - allocate(t2up_map,source=t1up_map) - call prepare_slab(tup_lat,tup_bas,t2up_map,up_term,jterm,& - up_thickness,up_ncells,up_height,ludef_up_surf,up_surf(2),& - "up",lcycle) - if(lcycle) cycle up_term_loop - - - !!----------------------------------------------------------------- - !! Checks stoichiometry - !!----------------------------------------------------------------- - if(tlw_bas%nspec.ne.inlw_bas%nspec.or.any(& - (inlw_bas%spec(1)%num*tlw_bas%spec(:)%num)& - /tlw_bas%spec(1)%num.ne.inlw_bas%spec(:)%num))then - write(6,'("WARNING: This lower surface termination is not & - &stoichiometric")') - if(lw_layered)then - write(6,'(2X,"As lower structure is layered, stoichiometric & - &surfaces are required.")') - write(6,'(2X,"Skipping this termination...")') - cycle lw_term_loop - end if - end if - if(tup_bas%nspec.ne.inup_bas%nspec.or.any(& - (inup_bas%spec(1)%num*tup_bas%spec(:)%num)& - /tup_bas%spec(1)%num.ne.inup_bas%spec(:)%num))then - write(6,'("WARNING: This upper surface termination is not & - &stoichiometric")') - if(up_layered)then - write(6,'(2X,"As upper structure is layered, stoichiometric & - &surfaces are required.")') - write(6,'(2X,"Skipping this termination...")') - cycle up_term_loop - end if - end if - - - !!----------------------------------------------------------------- - !! Use the bulk moduli to determine the strain sharing - !!----------------------------------------------------------------- - if(lw_bulk_modulus.ne.0.E0.and.up_bulk_modulus.ne.0.E0)then - call share_strain(tlw_lat,tup_lat,& - lw_bulk_modulus,up_bulk_modulus,lcompensate=.not.lc_fix) - end if - - - !!----------------------------------------------------------------- - !! Merge the two bases and lattices and define the interface loc - !!----------------------------------------------------------------- - call bas_lat_merge(& - slat,sbas,& - tlw_lat,tup_lat,& - tlw_bas,tup_bas,axis,init_offset(:),& - t2lw_map,t2up_map) - intf_loc(1) = ( modu(tlw_lat(axis,:)) + 0.5D0*init_offset(axis) - & - tmp_vac)/modu(slat(axis,:)) - intf_loc(2) = ( modu(tlw_lat(axis,:)) + modu(tup_lat(axis,:)) + & - 1.5D0*init_offset(axis) - 2.D0*tmp_vac )/modu(slat(axis,:)) - if(ierror.ge.1)then - write(0,*) "interface:",intf_loc - if(ierror.eq.1.and.iunique.eq.icheck_intf-1)then - call chdir(intf_dir) - call err_abort_print_struc(tlw_lat,tlw_bas,"lw_term.vasp",& - "",.false.) - call err_abort_print_struc(tup_lat,tup_bas,"up_term.vasp",& - "As IPRINT = 1 and ICHECK has been set, & - &code is now exiting...") - elseif(ierror.eq.2.and.iunique.eq.icheck_intf-1)then - call chdir(intf_dir) - call err_abort_print_struc(slat,sbas,"test_intf.vasp",& - "As IPRINT = 2 and ICHECK has been set, & - &code is now exiting...") - end if - end if - - - !!----------------------------------------------------------------- - !! Saves current directory and moves to new directory - !!----------------------------------------------------------------- - if(intf.gt.old_intf)then - iunique=iunique+1 - if(ishift.gt.0.and.nshift.gt.1) & - write(6,'(1X,"Generating shifts for unique interface ",& - &I0,":")') iunique - write(dirpath,'(A,I0.2)') trim(adjustl(subdir_prefix)),iunique - call system('mkdir -p '//trim(adjustl(dirpath))) - else - write(dirpath,'(A,I0.2)') trim(adjustl(subdir_prefix)),iunique - end if - call chdir(dirpath) - old_intf = intf - - - !!----------------------------------------------------------------- - !! Writes information of current match to file in save directory - !!----------------------------------------------------------------- - call output_intf_data(SAV, ifit, lw_term, iterm, up_term, jterm,& - lw_use_pricel,up_use_pricel) - - - !!----------------------------------------------------------------- - !! Generates shifts and swaps and prints the subsequent structures - !!----------------------------------------------------------------- - call gen_shifts_and_swaps(slat,sbas,axis,intf_loc,avg_min_bond,& - ishift,nshift,& - iswap,swap_den,nswap,t2lw_map) - - if(intf.ge.nintf) exit intf_loop - !call chdir(dirname) - call chdir(intf_dir) - - if(ludef_up_surf) exit up_term_loop - end do up_term_loop - if(ludef_lw_surf) exit lw_term_loop - end do lw_term_loop - !!----------------------------------------------------------------------- - !! Returns to working directory - !!----------------------------------------------------------------------- - call chdir(intf_dir) - - end do intf_loop - - call chdir(pwd) - - - return - end subroutine gen_interfaces -!!!############################################################################# - - -!!!############################################################################# -!!! Takes input interface structure and generates a set of shifts and swaps. -!!! Prints these new structures to POSCARs. -!!!############################################################################# -!!! ISWAP METHOD NOT YET SET UP - subroutine gen_shifts_and_swaps(lat,bas,axis,intf_loc,bond,& - ishift,nshift,& - iswap,swap_den,nswap,& - map) - implicit none - integer :: shift_unit=10 - integer :: ounit,iaxis,k,l - integer :: ngen_swaps,nswaps_per_cell - double precision :: dtmp1 - type(bas_type) :: tbas - type(bond_type) :: min_bond - character(1024) :: filename,dirpath,pwd1,pwd2,msg - integer, dimension(3) :: abc - double precision, dimension(2) :: intf_loc - double precision, dimension(3) :: toffset - double precision, dimension(3,3) :: tlat - type(bas_type), allocatable, dimension(:) :: bas_arr - double precision, allocatable, dimension(:,:) :: output_shifts - - integer, intent(in) :: axis - integer, intent(in) :: nshift,nswap - integer, intent(in) :: ishift,iswap - double precision, intent(in) :: bond,swap_den - type(bas_type), intent(in) :: bas - double precision, dimension(3,3), intent(in) :: lat - - integer, dimension(:,:,:), optional, intent(in) :: map - - -!!!----------------------------------------------------------------------------- -!!! Sets up shift axis -!!!----------------------------------------------------------------------------- - abc = [ 1, 2, 3 ] - abc = cshift(abc,axis) - - -!!!----------------------------------------------------------------------------- -!!! Sets up and moves to appropriate directories -!!!----------------------------------------------------------------------------- - call getcwd(pwd1) - if(ishift.gt.0.or.nshift.gt.1)then - call system('mkdir -p '//trim(adjustl(shiftdir))) - call chdir(shiftdir) - end if - call getcwd(pwd2) - open(unit=shift_unit,file="shift_vals.txt") - write(shift_unit,& - '("# interface_num shift (a,b,c) units=(direct,direct,Å)")') - - -!!!----------------------------------------------------------------------------- -!!! Generates sets of shifts based on shift version -!!!----------------------------------------------------------------------------- - if(ishift.eq.0.or.ishift.eq.1) allocate(output_shifts(nshift,3)) - select case(ishift) - case(1) - output_shifts(1,:3)=0.D0 - do k=2,nshift - do iaxis=1,2 - call random_number(output_shifts(k,iaxis)) - end do - end do - case(2) - output_shifts = get_fit_shifts(& - lat=lat,bas=bas,& - bond=bond,& - axis=axis,& - intf_loc=intf_loc,& - depth=intf_depth,& - nstore=nshift) - case(3) - output_shifts = get_descriptive_shifts(& - lat=lat,bas=bas,& - bond=bond,& - axis=axis,& - intf_loc=intf_loc,& - depth=intf_depth,c_scale=c_scale,& - nstore=nshift,lprint=lprint_shifts) - case(4) - if(present(map))then - output_shifts = get_shifts_DON(& - lat=lat,bas=bas,& - axis=axis,& - intf_loc=intf_loc,& - nstore=nshift,c_scale=c_scale,offset=offset(1,:3),& - lprint=lprint_shifts,bulk_DON=bulk_DON,bulk_map=map,& - max_bondlength=max_bondlength) - else - output_shifts = get_shifts_DON(& - lat=lat,bas=bas,& - axis=axis,& - intf_loc=intf_loc,& - nstore=nshift,c_scale=c_scale,offset=offset(1,:3),& - lprint=lprint_shifts,& - max_bondlength=max_bondlength) - end if - if(size(output_shifts(:,1)).eq.0)then - write(0,'(2X,"No shifts were identified with ISHIFT = 4 for this lattice match")') - write(0,'(2X,"We suggest increasing MBOND_MAXLEN to find shifts")') - write(0,'("Skipping interface...")') - return - end if - case default - ! nshift=1 !!! SORT THIS OUT !!! RESET NSHIFT DUE TO ISHIFT - if(.not.allocated(output_shifts)) allocate(output_shifts(1,3)) - output_shifts(:,:) = offset - do iaxis=1,2 - output_shifts(1,iaxis) = output_shifts(1,iaxis)!/modu(lat(iaxis,:)) - end do - end select - if(ishift.gt.0)then - output_shifts(:,axis) = output_shifts(:,axis)*modu(lat(axis,:)) - end if - - -!!!----------------------------------------------------------------------------- -!!! Prints number of shifts to terminal -!!!----------------------------------------------------------------------------- - write(6,'(3X,"Number of unique shifts structures: ",I0)') nshift - - -!!!----------------------------------------------------------------------------- -!!! Determines number of swaps across the interface -!!!----------------------------------------------------------------------------- - nswaps_per_cell=nint(swap_den*get_area(lat(abc(1),:),lat(abc(2),:))) - if(iswap.ne.0)then - write(6,& - '(" Generating ",I0," swaps per structure ")') nswaps_per_cell - end if - - -!!!----------------------------------------------------------------------------- -!!! Prints each unique shift structure -!!!----------------------------------------------------------------------------- - shift_loop: do k=1,nshift - call clone_bas(bas,tbas,lat,tlat) - toffset=output_shifts(k,:3) - do iaxis=1,2 - call shift_region(tbas,axis,& - intf_loc(1),intf_loc(2),& - shift_axis=iaxis,shift=toffset(iaxis),renorm=.true.) - end do - dtmp1=modu(tlat(axis,:)) - call set_vacuum(& - lat=tlat,bas=tbas,& - axis=axis,loc=maxval(intf_loc(:)),& - vac=toffset(axis)) - dtmp1=minval(intf_loc(:))*dtmp1/modu(tlat(axis,:)) - call set_vacuum(& - lat=tlat,bas=tbas,& - axis=axis,loc=dtmp1,& - vac=toffset(axis)) - min_bond = get_shortest_bond(tlat,tbas) - if(min_bond%length.le.1.5D0)then - write(msg,'("Smallest bond in the interface structure is\nless than 1.5 Å.")') - call print_warning(trim(msg)) - write(6,'(2X,"bond length: ",F9.6)') min_bond%length - write(6,'(2X,"atom 1:",I4,2X,I4)') min_bond%atoms(1,:) - write(6,'(2X,"atom 2:",I4,2X,I4)') min_bond%atoms(2,:) - end if - - - !!----------------------------------------------------------------------- - !! prints shift vector to shift_vals.txt - !!----------------------------------------------------------------------- - write(shift_unit,'(2X,I0.2,15X,"(",2(" ",F9.6,", ")," ",F9.6," )")') & - k,toffset(:) - - - !!----------------------------------------------------------------------- - !! Merges lower and upper materials - !! Writes interfaces to output directories - !!----------------------------------------------------------------------- - intf=intf+1 - ounit=100+intf - if(ishift.gt.0.or.nshift.gt.1)then - write(dirpath,'(A,I0.2)') trim(adjustl(subdir_prefix)),k - call system('mkdir -p '//trim(adjustl(dirpath))) - write(filename,'(A,"/",A)') trim(adjustl(dirpath)),trim(out_filename) - else - filename = trim(out_filename) - end if - write(6,'(2X,"Writing interface ",I0,"...")') intf - open(unit=ounit,file=trim(adjustl(filename))) - call geom_write(ounit,tlat,tbas) - close(ounit) - if(intf.ge.nintf) return - - - !!----------------------------------------------------------------------- - !! Performs swaps within the shifted structures if requested - !!----------------------------------------------------------------------- - if_swap: if(iswap.ne.0)then - bas_arr = rand_swapper(tlat,tbas,axis,swap_depth,& - nswaps_per_cell,nswap,intf_loc,iswap,seed,sigma=swap_sigma,& - require_mirror=lswap_mirror) - ngen_swaps = nswap - LOOPswaps: do l=1,nswap - if (bas_arr(l)%nspec.eq.0) then - ngen_swaps = l - 1 - exit LOOPswaps - end if - end do LOOPswaps - if(ngen_swaps.eq.0)then - exit if_swap - end if - call chdir(dirpath) - call system('mkdir -p '//trim(adjustl(swapdir))) - call chdir(swapdir) - write(6,'(3X,"Number of unique swap structures: ",I0)') ngen_swaps - do l=1,ngen_swaps - write(dirpath,'(A,I0.2)') trim(adjustl(subdir_prefix)),l - call system('mkdir -p '//trim(adjustl(dirpath))) - write(filename,'(A,"/",A)') & - trim(adjustl(dirpath)),trim(out_filename) - ounit=100+l - write(6,'(3X,"Writing swap ",I0,"...")') l - open(unit=ounit,file=trim(adjustl(filename))) - call geom_write(ounit,tlat,bas_arr(l)) - close(ounit) - end do - deallocate(bas_arr) - call chdir(pwd2) - end if if_swap - - - end do shift_loop - call chdir(pwd1) - close(unit=shift_unit) - - - end subroutine gen_shifts_and_swaps -!!!############################################################################# - - -!!!############################################################################# -!!! changes terminations to one long list of the top surfaces of the crystal -!!!############################################################################# - function get_term_list(term) result(list) - implicit none - integer :: i,j,itmp1,nlist,loc - type(term_arr_type), intent(in) :: term - - type(term_list_type) :: tmp_element - type(term_list_type), allocatable, dimension(:) :: list - - - if(.not.allocated(term%arr(1)%ladder))then - nlist=term%nterm - allocate(list(nlist)) - list(:)%loc = term%arr(:)%hmin - do i=1,term%nterm - list(i)%term = i - end do - else - nlist = term%nstep*term%nterm - allocate(list(nlist)) - itmp1=0 - do i=1,term%nterm - do j=1,term%nstep - itmp1=itmp1+1 - list(itmp1)%loc = term%arr(i)%hmin+term%arr(i)%ladder(j) - list(itmp1)%loc = list(itmp1)%loc - & - ceiling( list(itmp1)%loc - 1.D0 ) - list(itmp1)%term=i - end do - end do - end if - - !! sort the list now - do i=1,nlist - loc=minloc(list(i:nlist)%loc,dim=1)+i-1 - tmp_element=list(i) - list(i)=list(loc) - list(loc)=tmp_element - end do - - - - end function get_term_list -!!!############################################################################# - - -!!!############################################################################# -!!! sets the maximum height of the slab -!!!############################################################################# - subroutine set_slab_height(lat, bas, map, term, surf, old_natom,& - height, thickness, ncells,& - term_start, term_end, term_step, ludef_surf,& - intf_dir, lwup_in, lcycle) - implicit none - integer :: i,itmp1 - double precision :: dtmp1 - character(2) :: lwup - character(5) :: lowerupper - character(1024) :: msg - double precision, dimension(3,3) :: tfmat - double precision, allocatable, dimension(:) :: vtmp1 - type(term_list_type), allocatable, dimension(:) :: list - - integer, intent(in) :: thickness, old_natom - integer, intent(inout) :: term_start, term_end, ncells - integer, intent(out) :: term_step - double precision, intent(inout) :: height - character(2), intent(in) :: lwup_in - character(1024), intent(in) :: intf_dir - logical, intent(inout) :: ludef_surf - logical, intent(out) :: lcycle - type(bas_type), intent(inout) :: bas - type(term_arr_type), intent(inout) :: term - integer, dimension(2), intent(in) :: surf - double precision, dimension(3,3), intent(inout) :: lat - - integer, allocatable, dimension(:,:,:), intent(inout) :: map - - - !!-------------------------------------------------------------------- - !! Initialise variables - !!-------------------------------------------------------------------- - lwup=to_lower(lwup_in) - if(lwup.eq."lw") lowerupper="LOWER" - if(lwup.eq."up") lowerupper="UPPER" - - lcycle = .false. - height = 0.D0 - - - !!----------------------------------------------------------------------- - !! Defines height of slab from user-defined values - !!----------------------------------------------------------------------- - ludef_surf = .false. - term_start = 1 - term_end = min(term%nterm,nterm) - if(all(surf.ne.0))then - if(any(surf.gt.term%nterm))then - write(msg, '(A2,"_SURFACE VALUES INVALID!\nOne or more value & - &exceeds the maximum number of terminations in the & - structure.\n& - & Supplied values: ",I0,1X,I0,"\n& - & Maximum allowed: ",I0)') lwup, surf, term%nterm - call err_abort(trim(msg),fmtd=.true.) - end if - ludef_surf = .true. - list = get_term_list(term) - !! set term_start to first surface value - term_start = surf(1) - !! set term_end to first surface value as a user-defined surface ... - !! ... should not be cycled over. - !! it is just one, potentially assymetric, slab to be explored. - term_end = surf(1) - - !! determines the maximum number of cells required - allocate(vtmp1(size(list))) - height = term%arr(term_start)%hmin - do i=thickness,2,-1 - vtmp1 = list(:)%loc - height - vtmp1 = vtmp1 - ceiling( vtmp1 - 1.D0 ) - itmp1 = minloc( vtmp1(:), dim=1,& - mask=& - vtmp1(:).gt.0.and.& - list(:)%term.eq.surf(1)) - height = height + vtmp1(itmp1) - end do - vtmp1 = list(:)%loc - height - !vtmp1 = vtmp1 - ceiling( vtmp1 - 1.D0 ) - where(vtmp1.lt.-1.D-5) - vtmp1 = vtmp1 - ceiling( vtmp1 + 1.D-5 - 1.D0 ) - end where - itmp1 = minloc( vtmp1(:), dim=1,& - mask=& - vtmp1(:).ge.-1.D-5.and.& - list(:)%term.eq.surf(2)) - !!write(0,*) "temp",itmp1 - !!write(0,*) "temp",list(:)%loc - !!write(0,*) "SURFACES",surf - !write(0,*) "look",term%arr(term_start)%hmin, term_start - !write(0,*) vtmp1(itmp1),itmp1 - !write(0,*) list(:)%loc - !write(0,*) list(:)%loc-height - !write(0,*) vtmp1 - !write(0,*) list(:)%term - !write(0,*) "height check1", height - height = height + vtmp1(itmp1) - term%arr(term_start)%hmin - !write(0,*) "height check2", height - - !write(0,*) "mirror?",term%lmirror - !! if there is no mirror, we need to remove extra layers in the cell - !if(.not.term%lmirror)then - ! get thickness of top/surface layer - dtmp1 = term%arr(surf(2))%hmax - term%arr(surf(2))%hmin - if(dtmp1.lt.-1.D-5) dtmp1 = dtmp1 + 1.D0 - height = height + dtmp1 !(1.D0 - dtmp1) - !end if - - !write(0,*) "HEIGHT", height - ncells = ceiling(height) - height = height/dble(ncells) - end if - !write(0,*) "ncells",ncells - !write(0,*) "height",height - - - !!----------------------------------------------------------------------- - !! Define termination iteration counter - !!----------------------------------------------------------------------- - if(term_end.lt.term_start)then - term_step = -1 - else - term_step = 1 - end if - - - !!----------------------------------------------------------------------- - !! Extend slab to user-defined thickness - !!----------------------------------------------------------------------- - !write(0,*) "HERE",term%nstep,thickness - !write(0,*) thickness-1, (thickness-1)/term%nstep,int((thickness-1)/term%nstep)+1 - if(.not.ludef_surf) ncells = int((thickness-1)/term%nstep)+1 - !write(0,*) ncells - tfmat(:,:)=0.D0 - tfmat(1,1)=1.D0 - tfmat(2,2)=1.D0 - tfmat(3,3)=ncells - !write(0,*) "test0",ncells - call transformer(lat,bas,tfmat,map) - !write(0,*) "test1" - if(mod(real(old_natom*ncells)/real(bas%natom),1.0).gt.1.D-5)then - write(0,'(1X,"ERROR: Internal error in interfaces subroutine")') - write(0,'(2X,"gldfnd subroutine did not reproduce a sensible & - &primitive cell for ",A5," crystal")') lowerupper - write(0,'(2X,"Generated ",I0," atoms, from the original ",& - &I0," atoms")') & - bas%natom/itmp1,old_natom - if(ierror.eq.1)then - call chdir(intf_dir) - call err_abort_print_struc(lat,bas,& - "broken_primitive.vasp",& - "As IPRINT = 1, code is now exiting...") - end if - write(0,'(2X,"Skipping this lattice match...")') - lcycle=.true. - end if - - - !!----------------------------------------------------------------------- - !! Readjust termination plane locations - !! ... i.e. divide all termination values by the number of cells - !!----------------------------------------------------------------------- - term%arr(:)%hmin = term%arr(:)%hmin/dble(ncells) - term%arr(:)%hmax = term%arr(:)%hmax/dble(ncells) - term%tol = term%tol/dble(ncells) - - - end subroutine set_slab_height -!!!############################################################################# - - -!!!############################################################################# -!!! Set the tolerance for layer definitions -!!!############################################################################# - subroutine set_layer_tol(term) - implicit none - integer :: i - double precision :: dtmp1 - - type(term_arr_type), intent(inout) :: term - - - do i=1,term%nterm - if(i.eq.1)then - dtmp1 = abs(term%arr(i)%hmin - & - (term%arr(term%nterm)%hmax+term%arr(i)%ladder(term%nstep)-1.D0)& - )/4.D0 - else - dtmp1 = abs(term%arr(i)%hmin-term%arr(i-1)%hmax)/4.D0 - end if - if(dtmp1.lt.term%tol)then - term%tol = dtmp1 - end if - end do - - !! add the tolerances to the edges of the layers - !! this ensures that all atoms in the layers are captured - term%arr(:)%hmin = term%arr(:)%hmin - term%tol - term%arr(:)%hmax = term%arr(:)%hmax + term%tol - - - end subroutine set_layer_tol -!!!############################################################################# - - -!!!############################################################################# -!!! Prepares lattice and basis to specified termination -!!!############################################################################# -!!! Supply a supercell that can be cut down to the size of the slab ... -!!! ... i.e. the input structure must be larger or equal to the desired output - subroutine prepare_slab(lat, bas, map, term, iterm, thickness, ncells, & - height, ludef_surf, udef_top_iterm, lwup_in, lcycle, & - ludef_ortho, udef_vacuum) - implicit none - integer :: j, j_start, istep, natom_check - double precision :: vacuum, dtmp1 - character(2) :: lwup - character(5) :: lowerupper - character(1024) :: msg - logical :: lortho - integer, dimension(3) :: abc=(/1,2,3/) - double precision, dimension(3,3) :: tfmat - integer, allocatable, dimension(:) :: iterm_list - - integer, intent(in) :: iterm, udef_top_iterm, thickness, ncells - double precision, intent(in) :: height - character(2), intent(in) :: lwup_in - logical, intent(in) :: ludef_surf - logical, intent(out) :: lcycle - type(bas_type), intent(inout) :: bas - type(term_arr_type), intent(in) :: term - double precision, dimension(3,3), intent(inout) :: lat - - integer, allocatable, dimension(:,:,:), intent(inout) :: map - logical, optional, intent(in) :: ludef_ortho - double precision, optional, intent(in) :: udef_vacuum - - !!-------------------------------------------------------------------- - !! Initialise variables - !!-------------------------------------------------------------------- - lwup=to_lower(lwup_in) - if(lwup.eq."lw") lowerupper="LOWER" - if(lwup.eq."up") lowerupper="UPPER" - lcycle = .false. - dtmp1=0.D0 - tfmat=0.D0 - istep = thickness - (ncells-1)*term%nstep - natom_check = bas%natom - - if(present(ludef_ortho))then - lortho = ludef_ortho - else - lortho = .true. - end if - - if(present(udef_vacuum))then - vacuum = udef_vacuum - else - vacuum = tmp_vac - end if - - - !!-------------------------------------------------------------------- - !! Set up list for checking expected number of atoms - !!-------------------------------------------------------------------- - allocate(iterm_list(term%nterm)) - do j=1,term%nterm - iterm_list(j) = j - end do - iterm_list=cshift(iterm_list,term%nterm-iterm+1) - if(ludef_surf)then - j_start = udef_top_iterm - iterm + 1 - if(j_start.le.0) j_start = j_start + term%nterm - j_start = j_start + 1 !+ (istep-1)*term%nterm/term%nstep - else - !! handle ladder steps that are equivalent - j_start = 2 !+ (istep-1)*term%nterm/term%nstep - end if - - - !!-------------------------------------------------------------------- - !! Shift lower material to specified termination - !!-------------------------------------------------------------------- - call shifter(bas,term%axis,-term%arr(iterm)%hmin,.true.) - !open(20,file="test.vasp") - !call geom_write(20,lat,bas) - !close(20) - - - !!-------------------------------------------------------------------- - !! Determine cell reduction to specified termination - !!-------------------------------------------------------------------- - !write(0,*) "LUDEF_SURF?", ludef_surf - do j=1,3 - tfmat(j,j)=1.D0 - if(j.eq.term%axis)then - if(ludef_surf)then - tfmat(j,j) = height !+ term%tol*2.D0 - else!if(term%lmirror)then - if(istep.ne.0)then - dtmp1 = (ncells-1) + term%arr(iterm)%ladder(istep) - dtmp1 = dtmp1/(ncells) - tfmat(j,j) = dtmp1 !+ term%tol*2.D0 - tfmat(j,j) = tfmat(j,j) + & - (term%arr(iterm)%hmax - term%arr(iterm)%hmin) - end if - !else - ! tfmat(j,j) = tfmat(j,j) + (& - ! term%arr(iterm)%hmax - & - ! term%arr(iterm)%hmin) + term%tol*2.D0 - end if - end if - end do - - - !!-------------------------------------------------------------------- - !! Apply transformation and shift cell back to bottom of layer - !! ... i.e. account for the tolerance that has been added to layer ... - !! ... hmin and hmax - !!-------------------------------------------------------------------- - call transformer(lat,bas,tfmat,map) - call shifter(bas,term%axis,-term%tol/tfmat(term%axis,term%axis),.true.) - - - !!-------------------------------------------------------------------- - !! Check number of atoms is expected - !!-------------------------------------------------------------------- - if(term%nterm.gt.1.or.term%nstep.gt.1)then - do j=1,max(0,term%nstep-istep),1 - natom_check = natom_check - sum(term%arr(:)%natom) - end do - do j=j_start,term%nterm,1 - natom_check = natom_check - term%arr(iterm_list(j))%natom - end do - end if - if(bas%natom.ne.natom_check)then - write(msg, '("NUMBER OF ATOMS IN '//to_upper(lowerupper)//' SLAB! & - &Expected ",I0," but generated ",I0," instead")') & - natom_check,bas%natom - if(tfmat(term%axis,term%axis).gt.1.D0)then - write(0,'("THE TRANSFORMATION IS GREATER THAN ONE ",F0.9)') & - tfmat(term%axis,term%axis) - end if - !call err_abort(trim(msg),fmtd=.true.) - call err_abort_print_struc(lat,bas,lwup//"_term.vasp",& - trim(msg),.true.) - lcycle = .true. - end if - - - !!-------------------------------------------------------------------- - !! Apply slab_cuber to orthogonalise lower material - !!-------------------------------------------------------------------- - call normalise_basis(bas,dtmp=0.9999D0,lfloor=.true.,zero_round=0.D0) - call set_vacuum(lat,bas,term%axis,1.D0-term%tol/tfmat(term%axis,term%axis),vacuum) - !call err_abort_print_struc(lat,bas,"check.vasp","stop") - abc=cshift(abc,3-term%axis) - if(lortho)then - ortho_check: do j=1,2 - if(abs(dot_product(lat(abc(j),:),lat(axis,:))).gt.1.D-5)then - call ortho_axis(lat,bas,term%axis) - exit ortho_check - end if - end do ortho_check - end if - call normalise_basis(bas,dtmp=0.9999D0,lfloor=.true.,zero_round=0.D0) - - - end subroutine prepare_slab -!!!############################################################################# - - -!!!############################################################################# -!!! write structure data in each structure directory -!!!############################################################################# - subroutine output_intf_data(SAV, ifit, lw_term, ilw_term, up_term, iup_term, lw_pricel,up_pricel) - implicit none - integer :: unit - - integer, intent(in) :: ifit, ilw_term, iup_term - logical, intent(in) :: lw_pricel,up_pricel - type(term_arr_type), intent(in) :: lw_term, up_term - type(latmatch_type), intent(in) :: SAV - - - - unit=99 - open(unit=unit, file="struc_dat.txt") - write(unit,'("Lower material primitive cell used: ",L1)') lw_pricel - write(unit,'("Upper material primitive cell used: ",L1)') lw_pricel - write(unit,*) - write(unit,'("Lattice match:")') - write(unit,'((1X,3(3X,A1),3X,3(3X,A1)),3(/,2X,3(I3," "),3X,3(I3," ")))') & - SAV%abc,SAV%abc,& - SAV%tf1(ifit,1,1:3),SAV%tf2(ifit,1,1:3),& - SAV%tf1(ifit,2,1:3),SAV%tf2(ifit,2,1:3),& - SAV%tf1(ifit,3,1:3),SAV%tf2(ifit,3,1:3) - write(unit,'(" vector mismatch (%) = ",F0.9)') SAV%tol(ifit,1) - write(unit,'(" angle mismatch (°) = ",F0.9)') SAV%tol(ifit,2)*180/pi - write(unit,'(" area mismatch (%) = ",F0.9)') SAV%tol(ifit,3) - write(unit,*) - write(unit,'(" Lower crystal Miller plane: ",3(I3," "))') SAV%tf1(ifit,3,1:3) - write(unit,'(" Lower termination")') - write(unit,'(1X,"Term.",3X,"Min layer loc",3X,"Max layer loc",3X,"no. atoms")') - write(unit,'(1X,I3,8X,F7.5,9X,F7.5,8X,I3)') & - ilw_term,lw_term%arr(ilw_term)%hmin,lw_term%arr(ilw_term)%hmax,lw_term%arr(ilw_term)%natom - write(unit,*) - write(unit,'(" Upper crystal Miller plane: ",3(I3," "))') SAV%tf2(ifit,3,1:3) - write(unit,'(" Upper termination")') - write(unit,'(1X,"Term.",3X,"Min layer loc",3X,"Max layer loc",3X,"no. atoms")') - write(unit,'(1X,I3,8X,F7.5,9X,F7.5,8X,I3)') & - iup_term,up_term%arr(iup_term)%hmin,up_term%arr(iup_term)%hmax,up_term%arr(iup_term)%natom - write(unit,*) - close(unit) - - return - end subroutine output_intf_data -!!!############################################################################# - - -end module interface_subroutines diff --git a/src/lib/mod_constants.f90 b/src/lib/mod_constants.f90 deleted file mode 100644 index bd301c7..0000000 --- a/src/lib/mod_constants.f90 +++ /dev/null @@ -1,13 +0,0 @@ -MODULE constants - implicit none - real, parameter, public :: k_b = 1.3806503e-23 - real, parameter, public :: hbar = 1.05457148e-34 - real, parameter, public :: h = 6.626068e-34 - real, parameter, public :: atomic_mass=1.67262158e-27 - real, parameter, public :: avogadros=6.022e23 - real, parameter, public :: bohrtoang=0.529177249 - integer, parameter, public :: real12 = Selected_real_kind(15,307) - double precision, parameter, public :: pi = 4.D0*atan(1.D0) - double precision, parameter, public :: INF = huge(0.D0) - integer, public :: ierror = -1 -end MODULE constants diff --git a/src/lib/mod_rw_geom.f90 b/src/lib/mod_rw_geom.f90 deleted file mode 100644 index a2bd871..0000000 --- a/src/lib/mod_rw_geom.f90 +++ /dev/null @@ -1,972 +0,0 @@ -!!!############################################################################# -!!! Code written by Ned Thaddeus Taylor and Francis Huw Davies -!!! Code part of the ARTEMIS group (Hepplestone research group). -!!! Think Hepplestone, think HRG. -!!!############################################################################# -!!! Module made to read and write structure input files -!!! Currently supports: -!!! -VASP -!!! -Quantum Espresso -!!! -CASTEP -!!! -xyz (read only) -!!!############################################################################# -module rw_geom - use misc, only: to_upper,jump,Icount - use misc_linalg, only: LUinv,modu - implicit none - - private - - integer :: igeom_input=1,igeom_output=1 - double precision, dimension(3,3) :: lattice - - type spec_type - double precision, allocatable ,dimension(:,:) :: atom - double precision :: mass - character(len=5) :: name - integer :: num - end type spec_type - type bas_type - type(spec_type), allocatable, dimension(:) :: spec - integer :: nspec - integer :: natom - logical :: lcart=.false. - character(len=1024) :: sysname - end type bas_type - type(bas_type) :: basis - - - public :: igeom_input,igeom_output - public :: bas_type - public :: clone_bas - public :: convert_bas - public :: geom_read,geom_write - - -!!!updated 2020/02/06 - - -contains -!!!############################################################################# -!!! sets up the name of output files and subroutines to read files -!!!############################################################################# - subroutine geom_read(UNIT,lat,bas,length) - implicit none - integer :: UNIT,dim,i - type(bas_type) :: bas - double precision, dimension(3,3) :: lat - integer, optional, intent(in) :: length - - lattice=0.D0 - dim=3 - if(present(length)) dim=length - - select case(igeom_input) - case(1) - call VASP_geom_read(UNIT,dim) - case(2) - call CASTEP_geom_read(UNIT,dim) - case(3) - call QE_geom_read(UNIT,dim) - case(4) - !call err_abort('ERROR: ARTEMIS not yet set up for CRYSTAL') - write(0,'("ERROR: ARTEMIS not yet set up for CRYSTAL")') - stop - case(5) - call XYZ_geom_read(UNIT,dim) - write(0,'("WARNING: XYZ file format does not contain lattice data")') - end select - call clone_bas(basis,bas,lattice,lat) - deallocate(basis%spec) - if(dim.eq.4)then - do i=1,bas%nspec - bas%spec(i)%atom(:,4)=1.D0 - end do - end if - - - end subroutine geom_read -!!!############################################################################# - - -!!!############################################################################# -!!! sets up the name of output files and subroutines to read files -!!!############################################################################# - subroutine geom_write(UNIT,lat,bas) - implicit none - integer :: UNIT - type(bas_type) :: bas - double precision, dimension(3,3) :: lat - -!!! MAKE IT CHANGE HERE IF USER SPECIFIES LCART OR NOT -!!! AND GIVE IT THE CASTEP AND QE OPTION OF LABC !!! - - select case(igeom_output) - case(1) - call VASP_geom_write(UNIT,lat,bas) - case(2) - call CASTEP_geom_write(UNIT,lat,bas) - case(3) - call QE_geom_write(UNIT,lat,bas) - case(4) - write(0,'("ERROR: ARTEMIS not yet set up for CRYSTAL")') - stop - case(5) - write(0,'("ERROR: XYZ format doesn''t need lattice")') - call XYZ_geom_write(UNIT,bas) - end select - - - end subroutine geom_write -!!!############################################################################# - - -!!!############################################################################# -!!! read the POSCAR or CONTCAR file -!!!############################################################################# - subroutine VASP_geom_read(UNIT,length) - implicit none - integer :: UNIT,pos,count,Reason - double precision :: scal - character(len=100) :: lspec - character(len=1024) :: buffer - double precision, dimension(3,3) :: reclat - integer, intent(in), optional :: length - integer :: i,j,k,dim - - -!!!----------------------------------------------------------------------------- -!!! determines dimension of basis (include translation dimension for symmetry?) -!!!----------------------------------------------------------------------------- - if(present(length))then - dim = length - else - dim = 3 - end if - -!!!----------------------------------------------------------------------------- -!!! read system name -!!!----------------------------------------------------------------------------- - read(UNIT,'(A)',iostat=Reason) basis%sysname - if(Reason.ne.0)then - write(0,'(" The file is not in POSCAR format.")') - write(0,'(" Exiting code ...")') - call exit() - end if - read(UNIT,*) scal - - -!!!----------------------------------------------------------------------------- -!!! read lattice -!!!----------------------------------------------------------------------------- - do i=1,3 - read(UNIT,*) (lattice(i,j),j=1,3) - end do - lattice=scal*lattice - - -!!!----------------------------------------------------------------------------- -!!! read species names and number of each atomic species -!!!----------------------------------------------------------------------------- - read(UNIT,'(A)') lspec - basis%nspec=Icount(lspec) - allocate(basis%spec(basis%nspec)) - if(verify(lspec,' 0123456789').ne.0) then - count=0;pos=1 - speccount: do - i=verify(lspec(pos:), ' ') - if (i.eq.0) exit speccount - count=count+1 - pos=i+pos-1 - i=scan(lspec(pos:), ' ') - if (i.eq.0) exit speccount - basis%spec(count)%name=lspec(pos:pos+i-1) - pos=i+pos-1 - end do speccount - - read(UNIT,*) (basis%spec(j)%num,j=1,basis%nspec) - else !only numbers - do count=1,basis%nspec - write(basis%spec(count)%name,'(I0)') count - end do - read(lspec,*) (basis%spec(j)%num,j=1,basis%nspec) - end if - - -!!!----------------------------------------------------------------------------- -!!! determines whether input basis is in direct or cartesian coordinates -!!!----------------------------------------------------------------------------- - basis%lcart=.false. - read(UNIT,'(A)') buffer - if(verify(trim(buffer),'Direct').eq.0) basis%lcart=.false. - if(verify(trim(buffer),'Cartesian').eq.0) then - write(0,*) "NOT SURE IF CARTESIAN COORDINATES ARE SUPPORTED YET!" - write(0,*) "PLEASE CHECK COORDINATES" - basis%lcart=.true. - end if - - -!!!----------------------------------------------------------------------------- -!!! read basis -!!!----------------------------------------------------------------------------- - do i=1,basis%nspec - allocate(basis%spec(i)%atom(basis%spec(i)%num,dim)) - basis%spec(i)%atom(:,:)=0.D0 - do j=1,basis%spec(i)%num - read(UNIT,*) (basis%spec(i)%atom(j,k),k=1,3) - end do - end do - - -!!!----------------------------------------------------------------------------- -!!! convert basis if in cartesian coordinates -!!!----------------------------------------------------------------------------- - if(basis%lcart)then - reclat=transpose(LUinv(lattice)) - basis=convert_bas(basis,reclat) - end if - - -!!!----------------------------------------------------------------------------- -!!! normalise basis to between 0 and 1 in direct coordinates -!!!----------------------------------------------------------------------------- - do i=1,basis%nspec - do j=1,basis%spec(i)%num - do k=1,3 - basis%spec(i)%atom(j,k)=& - basis%spec(i)%atom(j,k)-floor(basis%spec(i)%atom(j,k)) - end do - end do - end do - basis%natom=sum(basis%spec(:)%num) - - - end subroutine VASP_geom_read -!!!############################################################################# - - -!!!############################################################################# -!!! writes out the structure in vasp poscar style format -!!!############################################################################# - subroutine VASP_geom_write(UNIT,lat_write,bas_write,lcart) - implicit none - integer :: i,j,UNIT - double precision, dimension(3,3) :: lat_write - type(bas_type) :: bas_write - character(100) :: fmt,string - logical, intent(in), optional :: lcart - - string="Direct" - if(present(lcart))then - if(lcart) string="Cartesian" - end if - - write(UNIT,'(A)') trim(adjustl(bas_write%sysname)) - write(UNIT,'(F15.9)') 1.D0 - do i=1,3 - write(UNIT,'(3(F15.9))') lat_write(i,:) - end do - write(fmt,'("(",I0,"(A,1X))")') bas_write%nspec - write(UNIT,trim(adjustl(fmt))) (adjustl(bas_write%spec(j)%name),j=1,bas_write%nspec) - write(fmt,'("(",I0,"(I0,5X))")') bas_write%nspec - write(UNIT,trim(adjustl(fmt))) (bas_write%spec(j)%num,j=1,bas_write%nspec) - write(UNIT,'(A)') trim(adjustl(string)) - do i=1,bas_write%nspec - do j=1,bas_write%spec(i)%num - write(UNIT,'(3(F15.9))') bas_write%spec(i)%atom(j,1:3) - end do - end do - - - end subroutine VASP_geom_write -!!!############################################################################# - - -!!!############################################################################# -!!! read the QE geom file -!!!############################################################################# - subroutine QE_geom_read(UNIT,length) - implicit none - integer UNIT,Reason,i,j,k,dim,iline - integer, dimension(1000) :: tmp_natom - integer, intent(in), optional :: length - double precision, dimension(3) :: tmpvec - double precision, dimension(3,3) :: reclat - character(len=5) :: ctmp - character(len=5), dimension(1000) :: tmp_spec - character(len=1024) :: buffer,buffer2 - - -!!!----------------------------------------------------------------------------- -!!! determines dimension of basis (include translation dimension for symmetry?) -!!!----------------------------------------------------------------------------- - if(present(length))then - dim = length - else - dim = 3 - end if - - basis%lcart=.false. - basis%sysname="Converted_from_geom_file" - - -!!!----------------------------------------------------------------------------- -!!! read lattice -!!!----------------------------------------------------------------------------- - rewind UNIT - cellparam: do - read(UNIT,'(A)',iostat=Reason) buffer - if(Reason.ne.0)then - write(0,'(" An issue with the QE input file format has been encountered.")') - write(0,'(" Exiting code ...")') - stop - end if - if(index(trim(buffer),"ibrav").ne.0)then - write(0,'("ERROR: Internal error in QE_geom_read")') - write(0,'(2X,"Subroutine not yet set up to read IBRAV lattices")') - stop - end if - if(verify("CELL_PARAMETERS",buffer).eq.0) then - exit cellparam - end if - end do cellparam - do i=1,3 - read(UNIT,*) (lattice(i,j),j=1,3) - end do - - -!!!----------------------------------------------------------------------------- -!!! determines whether input basis is in direct or cartesian coordinates -!!!----------------------------------------------------------------------------- - iline=0 - rewind UNIT - basfind: do - read(UNIT,'(A)',iostat=Reason) buffer - iline=iline+1 - if(verify("ATOMIC_POSITIONS",buffer).eq.0)then - backspace(UNIT) - read(UNIT,*) buffer,buffer2 - if(verify("crystal",buffer2).eq.0) basis%lcart=.false. - if(verify("angstrom",buffer2).eq.0) basis%lcart=.true. - exit basfind - end if - end do basfind - - -!!!----------------------------------------------------------------------------- -!!! read basis -!!!----------------------------------------------------------------------------- - basis%natom=0 - basis%nspec=0 - tmp_natom=1 - basread: do - read(UNIT,'(A)',iostat=Reason) buffer - read(buffer,*) ctmp - if(Reason.ne.0) exit - if(trim(ctmp).eq.'') exit - if(verify(buffer,' 0123456789').eq.0) exit - basis%natom=basis%natom+1 - if(.not.any(tmp_spec(1:basis%nspec).eq.ctmp))then - basis%nspec=basis%nspec+1 - tmp_spec(basis%nspec)=ctmp - else - where(tmp_spec(1:basis%nspec).eq.ctmp) - tmp_natom(1:basis%nspec)=tmp_natom(1:basis%nspec)+1 - end where - end if - end do basread - - allocate(basis%spec(basis%nspec)) - basis%spec(1:basis%nspec)%name=tmp_spec(1:basis%nspec) - do i=1,basis%nspec - basis%spec(i)%num=0 - allocate(basis%spec(i)%atom(tmp_natom(i),dim)) - end do - - call jump(UNIT,iline) - basread2: do i=1,basis%natom - read(UNIT,*,iostat=Reason) ctmp,tmpvec(1:3) - do j=1,basis%nspec - if(basis%spec(j)%name.eq.ctmp)then - basis%spec(j)%num=basis%spec(j)%num+1 - basis%spec(j)%atom(basis%spec(j)%num,1:3)=tmpvec(1:3) - exit - end if - end do - end do basread2 - - -!!!----------------------------------------------------------------------------- -!!! convert basis if in cartesian coordinates -!!!----------------------------------------------------------------------------- - if(basis%lcart)then - reclat=transpose(LUinv(lattice)) - basis=convert_bas(basis,reclat) - end if - - -!!!----------------------------------------------------------------------------- -!!! normalise basis to between 0 and 1 in direct coordinates -!!!----------------------------------------------------------------------------- - do i=1,basis%nspec - do j=1,basis%spec(i)%num - do k=1,3 - basis%spec(i)%atom(j,k)=& - basis%spec(i)%atom(j,k)-floor(basis%spec(i)%atom(j,k)) - end do - end do - end do - basis%natom=sum(basis%spec(:)%num) - - - end subroutine QE_geom_read -!!!############################################################################# - - -!!!############################################################################# -!!! writes out the structure in QE geom style format -!!!############################################################################# - subroutine QE_geom_write(UNIT,lat_write,bas_write,lcart) - implicit none - integer :: i,j,UNIT - double precision, dimension(3,3) :: lat_write - type(bas_type) :: bas_write - character(10) :: string - logical, intent(in), optional :: lcart - - string="crystal" - if(present(lcart))then - if(lcart) string="angstrom" - end if - - - write(UNIT,'("CELL_PARAMETERS angstrom")') - do i=1,3 - write(UNIT,'(3(F15.9))') lat_write(i,:) - end do - write(UNIT,'("ATOMIC_SPECIES")') - do i=1,bas_write%nspec - write(UNIT,'(A)') trim(adjustl(bas_write%spec(i)%name)) - end do - write(UNIT,'("ATOMIC_POSITIONS",1X,A)') trim(adjustl(string)) - do i=1,bas_write%nspec - do j=1,bas_write%spec(i)%num - write(UNIT,'(A5,1X,3(F15.9))') bas_write%spec(i)%name,bas_write%spec(i)%atom(j,1:3) - end do - end do - - - end subroutine QE_geom_write -!!!############################################################################# - - -!!!############################################################################# -!!! reads atoms from an CASTEP file -!!!############################################################################# - subroutine CASTEP_geom_read(UNIT,length) - implicit none - integer :: UNIT,Reason,itmp1 - integer :: i,j,k,dim,iline - character(len=5) :: ctmp - character(len=20) :: units - character(len=200) :: buffer,store - logical :: labc - integer, dimension(1000) :: tmp_natom - double precision, dimension(3) :: abc,angle,dvtmp1 - double precision, dimension(3,3) :: reclat - character(len=5), dimension(1000) :: tmp_spec - integer, intent(in), optional :: length - - -!!!----------------------------------------------------------------------------- -!!! determines dimension of basis (include translation dimension for symmetry?) -!!!----------------------------------------------------------------------------- - if(present(length))then - dim = length - else - dim = 3 - end if - - -!!!----------------------------------------------------------------------------- -!!! reading loop of file -!!!----------------------------------------------------------------------------- - tmp_spec="" - tmp_natom=0 - iline=0 - basis%sysname="from CASTEP" - rewind(UNIT) - readloop: do - iline=iline+1 - read(UNIT,'(A)',iostat=Reason) buffer - if(Reason.ne.0) exit - buffer=to_upper(buffer) - if(scan(trim(adjustl(buffer)),'%').ne.1) cycle readloop - if(index(trim(adjustl(buffer)),'%END').eq.1) cycle readloop - read(buffer,*) store, buffer - if(trim(buffer).eq.'') cycle readloop - !!------------------------------------------------------------------------ - !! read lattice - !!------------------------------------------------------------------------ - lattice_if: if(index(trim(buffer),"LATTICE").eq.1)then - if(index(trim(buffer),"ABC").ne.0) labc=.true. - if(index(trim(buffer),"CART").ne.0) labc=.false. - store="" - itmp1=0 - lattice_loop: do - itmp1=itmp1+1 - read(UNIT,'(A)',iostat=Reason) buffer - if(Reason.ne.0) exit lattice_loop - if(scan(trim(adjustl(buffer)),'%').eq.1) exit lattice_loop - if(itmp1.eq.5)then - write(0,'("ERROR: Too many lines in LATTICE block of structure file")') - stop - end if - store=trim(store)//" "//trim(buffer) - end do lattice_loop - iline=iline+itmp1 - - if(labc)then - read(store,*) units,(abc(i),i=1,3), (angle(j),j=1,3) - lattice=convert_abc_to_lat(abc,angle,.false.) - else - read(store,*) units,(lattice(i,:),i=1,3) - end if - cycle readloop - end if lattice_if - - !!------------------------------------------------------------------------ - !! read basis - !!------------------------------------------------------------------------ - basis_if: if(index(trim(buffer),"POSITIONS").eq.1) then - if(index(trim(buffer),"ABS").ne.0) basis%lcart=.true. - if(index(trim(buffer),"FRAC").ne.0) basis%lcart=.false. - itmp1=0 - basis_loop1: do - read(UNIT,'(A)',iostat=Reason) buffer - if(Reason.ne.0) exit basis_loop1 - if(scan(trim(adjustl(buffer)),'%').eq.1) exit basis_loop1 - read(buffer,*) ctmp - if(trim(ctmp).eq.'') exit - if(verify(buffer,' 0123456789').eq.0) exit - basis%natom=basis%natom+1 - if(.not.any(tmp_spec(1:basis%nspec).eq.ctmp))then - basis%nspec=basis%nspec+1 - tmp_natom(basis%nspec)=1 - tmp_spec(basis%nspec)=ctmp - else - where(tmp_spec(1:basis%nspec).eq.ctmp) - tmp_natom(1:basis%nspec)=tmp_natom(1:basis%nspec)+1 - end where - end if - end do basis_loop1 - - allocate(basis%spec(basis%nspec)) - basis%spec(1:basis%nspec)%name=tmp_spec(1:basis%nspec) - do i=1,basis%nspec - basis%spec(i)%num=0 - allocate(basis%spec(i)%atom(tmp_natom(i),dim)) - end do - - call jump(UNIT,iline) - basis_loop2: do i=1,basis%natom - read(UNIT,'(A)',iostat=Reason) buffer - if(Reason.ne.0)then - write(0,'("ERROR: Internal error in assigning the basis")') - stop - end if - read(buffer,*) ctmp,dvtmp1(1:3) - species_loop: do j=1,basis%nspec - if(basis%spec(j)%name.eq.ctmp)then - basis%spec(j)%num=basis%spec(j)%num+1 - basis%spec(j)%atom(basis%spec(j)%num,1:3)=dvtmp1(1:3) - exit species_loop - end if - end do species_loop - end do basis_loop2 - - end if basis_if - - end do readloop - - -!!!----------------------------------------------------------------------------- -!!! convert basis if in cartesian coordinates -!!!----------------------------------------------------------------------------- - if(basis%lcart)then - reclat=transpose(LUinv(lattice)) - basis=convert_bas(basis,reclat) - end if - - -!!!----------------------------------------------------------------------------- -!!! normalise basis to between 0 and 1 in direct coordinates -!!!----------------------------------------------------------------------------- - do i=1,basis%nspec - do j=1,basis%spec(i)%num - do k=1,3 - basis%spec(i)%atom(j,k)=& - basis%spec(i)%atom(j,k)-floor(basis%spec(i)%atom(j,k)) - end do - end do - end do - basis%natom=sum(basis%spec(:)%num) - - - return - end subroutine CASTEP_geom_read -!!!############################################################################# - - -!!!############################################################################# -!!! writes lattice and basis in a CASTEP file format -!!!############################################################################# - subroutine CASTEP_geom_write(UNIT,lat_write,bas_write,labc,lcart) - implicit none - integer :: i,j,UNIT - double precision, dimension(3) :: abc,angle - double precision, dimension(3,3) :: lat_write - type(bas_type) :: bas_write - character(4) :: string_lat,string_bas - logical, intent(in), optional :: labc,lcart - - - string_lat="CART" - if(present(labc))then - if(labc) string_lat="ABC" - end if - - string_bas="FRAC" - if(present(lcart))then - if(lcart)then - string_bas="ABS" - write(0,'("ERROR: Internal error in CASTEP_geom_write")') - write(0,'(2X,"Subroutine not yet set up to output cartesian & - &coordinates")') - stop - end if - end if - - write(UNIT,'("%block LATTICE_",A)') trim(string_lat) - write(UNIT,'("ang")') - if(present(labc))then - if(labc)then - do i=1,3 - abc(i)=modu(lat_write(i,:)) - end do - angle(1) = dot_product(lat_write(2,:),lat_write(3,:))/(abc(2)*abc(3)) - angle(2) = dot_product(lat_write(1,:),lat_write(3,:))/(abc(1)*abc(3)) - angle(3) = dot_product(lat_write(1,:),lat_write(2,:))/(abc(1)*abc(2)) - write(UNIT,'(3(F15.9))') abc - write(UNIT,'(3(F15.9))') angle - goto 10 - end if - end if - do i=1,3 - write(UNIT,'(3(F15.9))') lat_write(i,:) - end do - -10 write(UNIT,'("%endblock LATTICE_",A)') trim(string_lat) - - write(UNIT,*) - write(UNIT,'("%block POSITIONS_",A)') trim(string_bas) - do i=1,bas_write%nspec - do j=1,bas_write%spec(i)%num - write(UNIT,'(A5,1X,3(F15.9))') bas_write%spec(i)%name,bas_write%spec(i)%atom(j,1:3) - end do - end do - write(UNIT,'("%endblock POSITIONS_",A)') trim(string_bas) - - - end subroutine CASTEP_geom_write -!!!############################################################################# - - -!!!############################################################################# -!!! reads atoms from an xyz file -!!!############################################################################# - subroutine XYZ_geom_read(UNIT,length) - implicit none - integer :: UNIT,Reason - integer, intent(in), optional :: length - integer, allocatable, dimension(:) :: tmp_num - double precision, dimension(3) :: vec - double precision, allocatable, dimension(:,:,:) :: tmp_bas - character(len=5) :: ctmp - character(len=5), allocatable, dimension(:) :: tmp_spec - integer :: i,j,dim - - dim=3 - if(present(length)) dim=length - - - read(UNIT,*,iostat=Reason) basis%natom - if(Reason.ne.0)then - write(0,'(" The file is not in xyz format.")') - write(0,'(" Exiting code ...")') - call exit() - end if - read(UNIT,'(A)',iostat=Reason) basis%sysname - - -!!!----------------------------------------------------------------------------- -!!! read basis -!!!----------------------------------------------------------------------------- - allocate(tmp_spec(basis%natom)) - allocate(tmp_num(basis%natom)) - allocate(tmp_bas(basis%natom,basis%natom,dim)) - tmp_num(:)=0 - tmp_spec="" - tmp_bas=0 - basis%nspec=0 - do i=1,basis%natom - read(UNIT,*,iostat=Reason) ctmp,vec(1:3) - if(.not.any(tmp_spec(1:basis%nspec).eq.ctmp))then - basis%nspec=basis%nspec+1 - tmp_spec(basis%nspec)=ctmp - tmp_bas(basis%nspec,1,1:3)=vec(1:3) - tmp_num(basis%nspec)=1 - else - checkspec: do j=1,basis%nspec - if(tmp_spec(j).eq.ctmp)then - tmp_num(j)=tmp_num(j)+1 - tmp_bas(j,tmp_num(j),1:3)=vec(1:3) - exit checkspec - end if - end do checkspec - end if - end do - - -!!!----------------------------------------------------------------------------- -!!! move basis from temporary basis to main basis. -!!! done to allow for correct allocation of number of and per species -!!!----------------------------------------------------------------------------- - allocate(basis%spec(basis%nspec)) - basis%spec(1:basis%nspec)%name=tmp_spec(1:basis%nspec) - do i=1,basis%nspec - basis%spec(i)%name=tmp_spec(i) - basis%spec(i)%num=tmp_num(i) - allocate(basis%spec(i)%atom(tmp_num(i),dim)) - basis%spec(i)%atom(:,:)=0 - basis%spec(i)%atom(1:tmp_num(i),1:3)=tmp_bas(i,1:tmp_num(i),1:3) - end do - - - end subroutine XYZ_geom_read -!!!############################################################################# - - -!!!############################################################################# -!!! generates cartesian basis -!!!############################################################################# - subroutine XYZ_geom_write(UNIT,bas_write) - implicit none - integer :: i,j,UNIT - type(bas_type) :: bas_write - - - write(UNIT,'("I0")') bas_write%natom - write(UNIT,'("A")') bas_write%sysname - do i=1,bas_write%nspec - do j=1,bas_write%spec(i)%num - write(UNIT,'(A5,1X,3(F15.9))') & - bas_write%spec(i)%name,bas_write%spec(i)%atom(j,1:3) - end do - end do - - - end subroutine XYZ_geom_write -!!!############################################################################# - - -!!!############################################################################# -!!! convert basis using latconv transformation matrix -!!!############################################################################# - function convert_bas(inbas,latconv) result(outbas) - implicit none - integer :: is,ia,dim - type(bas_type) :: outbas - - type(bas_type), intent(in) :: inbas - double precision, dimension(3,3), intent(in) :: latconv - - - dim=size(inbas%spec(1)%atom(1,:)) - allocate(outbas%spec(inbas%nspec)) - outbas%natom=inbas%natom - outbas%nspec=inbas%nspec - outbas%sysname=inbas%sysname - outbas%lcart=.not.inbas%lcart - do is=1,inbas%nspec - allocate(outbas%spec(is)%atom(inbas%spec(is)%num,dim)) - outbas%spec(is)=inbas%spec(is) - do ia=1,inbas%spec(is)%num - outbas%spec(is)%atom(ia,1:3)=& - matmul(latconv,outbas%spec(is)%atom(ia,1:3)) - end do - end do - - end function convert_bas -!!!############################################################################# - - -!!!############################################################################# -!!! converts lattice from abc and αβγ to lattice matrix -!!!############################################################################# - function convert_abc_to_lat(abc,angle,radians) result(out_lat) - use constants, only: pi - implicit none - double precision, dimension(3) :: in_angle - double precision, dimension(3,3) :: out_lat - - double precision, dimension(3), intent(in) :: abc,angle - - logical, optional, intent(in) :: radians - - - if(present(radians))then - if(.not.radians) in_angle=angle*pi/180.D0 - end if -! in_angle=angle*pi/180.D0 ! this looks wrong, check it - - out_lat=0.D0 - - out_lat(1,1)=abc(1) - out_lat(2,:2)=(/abc(2)*cos(in_angle(3)),abc(2)*sin(in_angle(3))/) - - out_lat(3,1) = abc(3)*cos(in_angle(2)) - out_lat(3,2) = abc(3)*(cos(in_angle(1)) - cos(in_angle(2))*& - cos(in_angle(3)))/sin(in_angle(3)) - out_lat(3,3) = sqrt(abc(3)**2.D0 - out_lat(3,1)**2.D0 - out_lat(3,2)**2.D0) - - - end function convert_abc_to_lat -!!!############################################################################# - - -!!!############################################################################# -!!! converts lattice from matrix to abc and αβγ -!!!############################################################################# - function convert_lat_to_abc(in_lat,radians) result(abc_angle) - use constants, only: pi - implicit none - integer :: i - double precision, dimension(2,3) :: abc_angle - - double precision, dimension(3,3), intent(in) :: in_lat - - logical, optional, intent(in) :: radians - - - do i=1,3 - abc_angle(1,i)=modu(in_lat(i,:)) - end do - do i=1,3 - end do - abc_angle(2,1)=acos(dot_product(in_lat(2,:),in_lat(3,:))/& - (abc_angle(1,2)*abc_angle(1,3))) - abc_angle(2,3)=acos(dot_product(in_lat(1,:),in_lat(3,:))/& - (abc_angle(1,1)*abc_angle(1,3))) - abc_angle(2,3)=acos(dot_product(in_lat(1,:),in_lat(2,:))/& - (abc_angle(1,1)*abc_angle(1,2))) - - if(present(radians))then - if(.not.radians) abc_angle(2,:)=abc_angle(2,:)*180.D0/pi - end if - - end function convert_lat_to_abc -!!!############################################################################# - - -!!!############################################################################# -!!! clones basis 1 onto basis 2 -!!!############################################################################# - subroutine clone_bas(inbas,outbas,inlat,outlat,trans_dim) - implicit none - integer :: i - integer :: indim,outdim - double precision :: val - logical :: udef_trans_dim - - type(bas_type) :: inbas,outbas - double precision, dimension(3,3), optional :: inlat,outlat - - logical, optional, intent(in) :: trans_dim - - -!!!----------------------------------------------------------------------------- -!!! determines whether user wants output basis extra translational dimension -!!!----------------------------------------------------------------------------- - indim = size(inbas%spec(1)%atom(1,:),dim=1) - if(present(trans_dim))then - udef_trans_dim = trans_dim - elseif(indim.eq.4)then - udef_trans_dim = .true. - elseif(indim.eq.3)then - udef_trans_dim = .false. - end if - - -!!!----------------------------------------------------------------------------- -!!! sets up output basis atomic coordinates dimension -!!!----------------------------------------------------------------------------- - if(udef_trans_dim)then - outdim = 4 - val = 1.D0 - else - outdim = 3 - val = 0.D0 - end if - - -!!!----------------------------------------------------------------------------- -!!! if already allocated, deallocates output basis -!!!----------------------------------------------------------------------------- - if(allocated(outbas%spec))then - do i=1,outbas%nspec - if(allocated(outbas%spec(i)%atom)) deallocate(outbas%spec(i)%atom) - end do - deallocate(outbas%spec) - end if - - -!!!----------------------------------------------------------------------------- -!!! allocates output basis and clones data from input basis to output basis -!!!----------------------------------------------------------------------------- - allocate(outbas%spec(inbas%nspec)) - do i=1,inbas%nspec - allocate(outbas%spec(i)%atom(& - inbas%spec(i)%num,outdim)) - if(indim.eq.outdim)then - outbas%spec(i)%atom(:,:indim) = inbas%spec(i)%atom(:,:indim) - elseif(outdim.gt.indim)then - outbas%spec(i)%atom(:,:indim) = inbas%spec(i)%atom(:,:indim) - outbas%spec(i)%atom(:,outdim) = val - else - outbas%spec(i)%atom(:,:outdim) = inbas%spec(i)%atom(:,:outdim) - end if - outbas%spec(i)%mass = inbas%spec(i)%mass - outbas%spec(i)%num = inbas%spec(i)%num - outbas%spec(i)%name = inbas%spec(i)%name - end do -! outbas = inbas !using this will reallocate outbas to inbas - outbas%nspec = inbas%nspec - outbas%natom = inbas%natom - outbas%lcart = inbas%lcart - outbas%sysname = inbas%sysname - - -!!!----------------------------------------------------------------------------- -!!! clones input lattice to output lattice, if requested -!!!----------------------------------------------------------------------------- - if(present(inlat).and.present(outlat))then - outlat=inlat - end if - - - return - end subroutine clone_bas -!!!############################################################################# - -end module rw_geom diff --git a/src/lib/mod_sym.f90 b/src/lib/mod_sym.f90 deleted file mode 100644 index 9524319..0000000 --- a/src/lib/mod_sym.f90 +++ /dev/null @@ -1,1921 +0,0 @@ -!!!############################################################################# -!!! Code written by Ned Thaddeus Taylor and Francis Huw Davies -!!! Code part of the ARTEMIS group (Hepplestone research group). -!!! Think Hepplestone, think HRG. -!!!############################################################################# -!!!module contains symmetry-related functions and subroutines. -!!!module includes the following functions and subroutines: -!!! sym_setup (calls mksym and allocates unallocated symmetry arrays) -!!! check_sym (checks supplied symmetries against supplied basis or ... -!!! ... checks whether the two supplied bases match after ... -!!! ... applying symmetries) -!!! gldfnd (output translations that maps two bases) -!!! mksym (makes array of symmetries that apply to supplied lattice -!!! clone_grp (clones ingrp to outgrp) -!!! symwrite (output human-readable supplied transformation matrix) -!!! basis_map (finds symmetry equivalent atoms in two bases based on ... -!!! ... the supplied transformation matrix) -!!! setup_ladder (sets up rungs of the layer ladder) -!!! get_terminations (finds all possible terminations along an axis) -!!! print_terminations (prints the terminations to individual files) -!!!############################################################################# -module mod_sym - use constants, only: pi - use misc, only: sort1D,sort2D,sort_col,set - use misc_linalg, only: modu,inverse_3x3,det,gcd,gen_group,cross,uvec - use rw_geom, only: bas_type,geom_write - use edit_geom, only: transformer,vacuumer,set_vacuum,shifter,& - clone_bas,get_closest_atom,ortho_axis,reducer,primitive_lat,get_min_dist - implicit none - integer :: ierror_sym=0 - integer :: s_start=1,s_end=0 - double precision :: tol_sym=5.D-5 - character(1) :: verb_sym="n" - integer, allocatable, dimension(:) :: symops_compare - double precision, allocatable, dimension(:,:,:) :: savsym - - interface get_wyckoff_atoms - procedure get_wyckoff_atoms_any,get_wyckoff_atoms_loc - end interface get_wyckoff_atoms - - - private - - - type spec_wyck_type - integer :: num - character(len=5) :: name - integer, allocatable, dimension(:) :: atom - end type spec_wyck_type - type wyck_type - integer :: nwyck - type(spec_wyck_type), allocatable, dimension(:) :: spec - end type wyck_type - - - type spcmap_type - integer, allocatable ,dimension(:) :: atom - end type spcmap_type - type basmap_type - type(spcmap_type), allocatable, dimension(:) :: spec - end type basmap_type - - type term_type - !double precision :: add - double precision :: hmin - double precision :: hmax - integer :: natom - integer :: nstep - double precision, allocatable, dimension(:) :: ladder - end type term_type - - type term_arr_type - integer :: nterm,axis,nstep - double precision :: tol - logical :: lmirror=.false. - type(term_type), allocatable, dimension(:) :: arr - end type term_arr_type - - - type confine_type - !! apply any confinement/constraints on symmetries - logical :: l=.false. - !! axis to confine - integer :: axis=0 - !! states whether to consider mirrors in only one plane - logical :: lmirror=.false. - !! if l=.false. -> laxis defines which axes are free - !! if l=.true. -> laxis defines which axes are confined - logical, dimension(3) :: laxis=(/.false.,.false.,.false./) - end type confine_type - - type sym_type - integer :: nsym,nlatsym,nsymop,npntop - logical :: lspace=.true. - logical :: lmolec=.false. - integer, allocatable, dimension(:) :: op - double precision, allocatable, dimension(:,:,:) :: sym - type(confine_type) :: confine - end type sym_type - - - public :: set_symmetry_tolerance - public :: ierror_sym,s_start,s_end - public :: sym_type - public :: clone_grp - public :: sym_setup,check_sym,gldfnd - - public :: get_primitive_cell - - public :: term_arr_type,confine_type - public :: get_terminations - - public :: basmap_type,basis_map - - public :: wyck_type - public :: get_wyckoff_atoms - - public :: symops_compare - - -!!!updated 2023/02/14 - - -contains -!!!############################################################################# -!!! redefines the symmetry tolerance/precision -!!!############################################################################# - subroutine set_symmetry_tolerance(tolerance) - implicit none - double precision, optional, intent(in) :: tolerance - - if(present(tolerance))then - tol_sym = tolerance - else - tol_sym = 1.D-6 - end if - - end subroutine set_symmetry_tolerance -!!!############################################################################# - - -!!!############################################################################# -!!! calls mksym and allocates symops and wyckoff arrays -!!!############################################################################# - subroutine sym_setup(grp,lat,predefined,new_start,tolerance) - implicit none - logical :: lpresent - - type(sym_type) :: grp - - double precision, dimension(3,3), intent(in) :: lat - double precision, optional, intent(in) :: tolerance - logical, optional, intent(in) :: predefined,new_start - - - if(present(tolerance)) call set_symmetry_tolerance(tolerance) - if(present(new_start))then - if(new_start)then - if(allocated(grp%op)) deallocate(grp%op) - if(allocated(grp%sym)) deallocate(grp%sym) - end if - end if - - if(present(predefined))then - if(predefined)then - call gen_fundam_sym_matrices(grp,lat) - goto 10 - end if - end if - call mksym(grp,lat) - -10 if(allocated(savsym)) deallocate(savsym) - if(allocated(symops_compare)) deallocate(symops_compare) - grp%nsymop=0 - - lpresent=.false. - if(present(new_start))then - if(new_start) lpresent=.true. - end if - if(.not.present(new_start).or.lpresent.or.s_end.eq.0)then - s_end=grp%nsym - end if - - - return - end subroutine sym_setup -!!!############################################################################# - - -!!!############################################################################# -!!! builds an array of the symmetries that apply to the supplied lattice -!!!############################################################################# -!!! tfbas : transformed basis -!!!############################################################################# - subroutine check_sym(grp,bas1,iperm,tmpbas2,wyckoff,lsave,lat,loc,lcheck_all) - implicit none - integer :: i,j,k,iatom,jatom,ispec,itmp1 - integer :: is,isym,jsym,count,ntrans - integer :: samecount,oldnpntop - logical :: lpresent,lsaving,lwyckoff,ltransformed - type(bas_type) :: bas2,tfbas - double precision, dimension(3) :: diff - double precision, dimension(3,3) :: ident - type(wyck_type), allocatable, dimension(:) :: wyck_check - double precision, allocatable, dimension(:,:) :: trans - double precision, allocatable, dimension(:,:,:) :: tmpsav - - type(bas_type), intent(in) :: bas1 - type(sym_type), intent(inout) :: grp - - integer, optional, intent(in) :: iperm - logical, optional, intent(in) :: lsave,lcheck_all - type(bas_type), optional, intent(in) :: tmpbas2 - type(wyck_type), optional, intent(inout) :: wyckoff - double precision, dimension(3), optional, intent(in) :: loc - double precision, dimension(3,3), optional, intent(in) :: lat - - -204 format(4(F11.6),/,4(F11.6),/,4(F11.6),/,4(F11.6)) - - -!!!----------------------------------------------------------------------------- -!!! allocated grp%op -!!!----------------------------------------------------------------------------- - if(allocated(grp%op)) deallocate(grp%op) - allocate(grp%op(grp%nsym*minval(bas1%spec(:)%num))) - grp%op = 0 - if(present(lsave))then - lsaving = lsave - else - lsaving = .false. - end if - - -!!!----------------------------------------------------------------------------- -!!! checks for optional arguments and assigns values if not present -!!!----------------------------------------------------------------------------- - if(present(tmpbas2)) then - bas2 = tmpbas2 - if(present(lcheck_all))then - lpresent = .not.lcheck_all - else - lpresent = .true. - end if - else - bas2 = bas1 - lpresent = .false. - end if - allocate(tmpsav(grp%nsym*minval(bas1%spec(:)%num),4,4)) - itmp1 = maxval(bas1%spec(:)%num) - - -!!!----------------------------------------------------------------------------- -!!! initialises variables -!!!----------------------------------------------------------------------------- - allocate(trans(minval(bas1%spec(:)%num+2),3)); trans = 0.D0 - allocate(tfbas%spec(bas1%nspec)) - itmp1 = size(bas1%spec(1)%atom(1,:),dim=1) - do is=1,bas1%nspec - allocate(tfbas%spec(is)%atom(bas1%spec(is)%num,itmp1)) - end do - grp%nsymop = 0 - grp%npntop = 0 - - -!!!----------------------------------------------------------------------------- -!!! if present, initialises wyckoff arrays -!!!----------------------------------------------------------------------------- - allocate(wyck_check(grp%nsym*minval(bas1%spec(:)%num))) - do isym=1,grp%nsym*minval(bas1%spec(:)%num) - allocate(wyck_check(isym)%spec(bas1%nspec)) - do ispec=1,bas1%nspec - allocate(wyck_check(isym)%spec(ispec)%atom(bas1%spec(ispec)%num)) - wyck_check(isym)%spec(ispec)%atom = 0 - end do - end do - if(present(wyckoff))then - lwyckoff = .true. - if(allocated(wyckoff%spec)) deallocate(wyckoff%spec) - wyckoff%nwyck = 0 - allocate(wyckoff%spec(bas1%nspec)) - do ispec=1,bas1%nspec - wyckoff%spec(ispec)%num = 0 - wyckoff%spec(ispec)%name = "" - allocate(wyckoff%spec(ispec)%atom(bas1%spec(ispec)%num)) - do iatom=1,bas1%spec(ispec)%num - wyckoff%spec(ispec)%atom(iatom) = iatom - end do - end do - else - lwyckoff = .false. - end if - - -!!!----------------------------------------------------------------------------- -!!! set up identity matrix as reference -!!!----------------------------------------------------------------------------- - ltransformed = .false. - ident = 0.D0 - do i=1,3 - ident(i,i) = 1.D0 - end do - - -!!!----------------------------------------------------------------------------- -!!! applying symmetries to basis to see if the basis conforms to any of them -!!!----------------------------------------------------------------------------- - itmp1 = 1 - symloop: do isym=s_start,s_end - if(verb_sym.eq.'d') write(77,*) isym !,a,b,c - if(verb_sym.eq.'d') write(77,204) grp%sym(isym,1:4,1:4) - if(ierror_sym.eq.2.or.ierror_sym.eq.3) write(77,204) & - grp%sym(isym,1:4,1:4) - !------------------------------------------------------------------------ - ! apply symmetry operator to basis - !------------------------------------------------------------------------ - do ispec=1,bas1%nspec - do iatom=1,bas1%spec(ispec)%num - tfbas%spec(ispec)%atom(iatom,1:3) = & - matmul(bas1%spec(ispec)%atom(iatom,1:4),grp%sym(isym,1:4,1:3)) - do j=1,3 - tfbas%spec(ispec)%atom(iatom,j) = & - tfbas%spec(ispec)%atom(iatom,j) - & - ceiling(tfbas%spec(ispec)%atom(iatom,j)-0.5D0) - end do - end do - end do - !------------------------------------------------------------------------ - ! check whether transformed basis matches original basis - !------------------------------------------------------------------------ - count=0 - spcheck: do ispec=1,bas1%nspec - diff = 0.D0 - samecount = 0 - wyck_check(itmp1)%spec(ispec)%atom = 0 - atmcheck: do iatom=1,bas1%spec(ispec)%num - atmcyc: do jatom=1,bas1%spec(ispec)%num - !if(wyck_check(itmp1)%spec(ispec)%atom(jatom).ne.0) cycle atmcyc - diff = tfbas%spec(ispec)%atom(iatom,1:3) - & - bas2%spec(ispec)%atom(jatom,1:3) - diff(:) = diff(:) - floor(diff(:)) - where((abs(diff(:)-1.D0)).lt.(tol_sym)) - diff(:)=0.D0 - end where - if(sqrt(dot_product(diff,diff)).lt.tol_sym)then - samecount = samecount + 1 - wyck_check(itmp1)%spec(ispec)%atom(iatom) = jatom - end if - if((iatom.eq.bas1%spec(ispec)%num).and.& - (jatom.eq.bas1%spec(ispec)%num))then - if (samecount.ne.bas1%spec(ispec)%num) goto 10 - end if - end do atmcyc - count = count + samecount - end do atmcheck - if(samecount.ne.bas1%spec(ispec)%num) goto 10 - end do spcheck - grp%npntop = grp%npntop + 1 - grp%nsymop = grp%nsymop + 1 - itmp1 = grp%nsymop + 1 - tmpsav(grp%nsymop,:,:) = grp%sym(isym,:,:) - grp%op(grp%nsymop) = isym - if(grp%nsymop.ne.0.and.lpresent) exit symloop -10 trans = 0.D0 - ntrans = 0 - !------------------------------------------------------------------------ - ! checks if translations are valid with the current symmetry operation - !------------------------------------------------------------------------ - if(grp%lspace) then - if(all(abs(grp%sym(isym,1:3,1:3)-ident).lt.tol_sym))then - ltransformed=.false. - else - ltransformed=.true. - end if - call gldfnd(grp%confine,& - bas2,tfbas,& - trans,ntrans,& - transformed=ltransformed,& - wyck_check=wyck_check(itmp1:)) - if(ntrans.gt.0) then - if(lpresent.and..not.lsaving)then - grp%nsymop = grp%nsymop + 1 - exit symloop - end if - transloop: do i=1,ntrans - if(dot_product(trans(i,:),trans(i,:)).lt.tol_sym) & - cycle transloop - if(ierror_sym.eq.3) write(77,*) trans(i,:) - if(isym.ne.1)then - do jsym=2,grp%nsymop - if(grp%op(jsym).eq.1) then - if(all(abs(trans(i,1:3)-tmpsav(jsym,4,1:3)).lt.& - tol_sym)) cycle transloop - diff = trans(i,1:3) - tmpsav(jsym,4,1:3) - do j=1,3 - diff(j) = diff(j) - floor(diff(j)) - if(diff(j).gt.0.5) diff(j) = diff(j) - 1.D0 - end do - do k=1,i - if(all(abs(diff-trans(k,1:3)).lt.tol_sym)) & - cycle transloop - end do - end if - end do - end if - grp%nsymop = grp%nsymop + 1 - itmp1 = grp%nsymop + 1 - tmpsav(grp%nsymop,:,:) = grp%sym(isym,:,:) - tmpsav(grp%nsymop,4,1:3) = trans(i,:) - grp%op(grp%nsymop) = isym - end do transloop - if(lpresent) exit symloop - end if - end if - oldnpntop = grp%npntop - end do symloop - - -!!!----------------------------------------------------------------------------- -!!! allocates and saves the array savsym if the first time submitted -!!!----------------------------------------------------------------------------- - if(lsaving)then - if(allocated(savsym)) deallocate(savsym) - allocate(savsym(grp%nsymop,4,4)) - savsym=0.D0 - savsym(:grp%nsymop,:,:)=tmpsav(:grp%nsymop,:,:) - savsym(:,4,4)=1.D0 - deallocate(tmpsav) - end if - - - iperm_if: if(present(iperm))then - select case(iperm) - case(-1) - return - case(0) - exit iperm_if - case default - if(.not.allocated(symops_compare))then - write(0,'("ERROR: Internal error in check_sym")') - write(0,'(2X,"check_sym in mod_sym.f90 is trying to assign a & - &value to symops_compare, which hasn''t been allocated")') - exit iperm_if - end if - symops_compare(iperm)=grp%nsymop - end select - end if iperm_if - - - if(lsaving)then - deallocate(grp%sym) - call move_alloc(savsym,grp%sym) - grp%nsym = grp%nsymop - end if - - -!!!----------------------------------------------------------------------------- -!!! if wyckoff present, set up wyckoff atoms -!!!----------------------------------------------------------------------------- - if(lwyckoff)then - if(present(lat).and.present(loc))then - wyckoff=get_wyckoff_atoms(wyck_check(:grp%nsymop),lat,bas1,loc) - else - wyckoff=get_wyckoff_atoms(wyck_check(:grp%nsymop)) - end if - end if - - - - return - end subroutine check_sym -!!!############################################################################# - - -!!!############################################################################# -!!! supplies the glides (if any) that are required to match the two bases ... -!!! ... "bas" and "tfbas" onto one another -!!!############################################################################# - subroutine gldfnd(confine,bas,tfbas,trans,ntrans,transformed,wyck_check) - implicit none - integer :: i,j,ispec,iatom,jatom,katom,itmp1 - integer :: minspecloc,samecount - logical :: lwyckoff - double precision, dimension(3) :: ttrans,tmpbas,diff - double precision, allocatable, dimension(:,:) :: sav_trans - - integer, intent(out) :: ntrans - type(bas_type), intent(in) :: bas,tfbas - type(confine_type), intent(in) :: confine - double precision, dimension(:,:), intent(out) :: trans - - logical, optional, intent(in) :: transformed - - type(wyck_type), dimension(:), optional, intent(inout) :: wyck_check - - -!!!----------------------------------------------------------------------------- -!!! Allocate arrays and initialise variables -!!!----------------------------------------------------------------------------- - ttrans=0.D0 - trans=0.D0 - samecount=0 - ntrans=0 - minspecloc=minloc(bas%spec(:)%num,mask=bas%spec(:)%num.ne.0,dim=1) - - if(present(transformed))then - if(.not.transformed)then - if(bas%spec(minspecloc)%num.eq.1) return - end if - else - if(bas%spec(minspecloc)%num.eq.1) return - end if - allocate(sav_trans(bas%natom,3)) - - -!!!----------------------------------------------------------------------------- -!!! if present, initialises tmp_wyckoff arrays -!!!----------------------------------------------------------------------------- - if(present(wyck_check))then - lwyckoff=.true. - else - lwyckoff=.false. - end if - - -!!!----------------------------------------------------------------------------- -!!! Cycles through each atom in transformed basis and finds translation ... -!!! ... vector that maps it back onto the 1st atom in the original, ... -!!! ... untransformed, basis. -!!! Then tests this translation vector on all other atoms to see if it works ... -!!! ... as a translation vector for the symmetry. -!!!----------------------------------------------------------------------------- - trloop: do iatom=1,bas%spec(minspecloc)%num - ttrans(:)=0.D0 - ttrans(1:3)=bas%spec(minspecloc)%atom(1,1:3)-& - tfbas%spec(minspecloc)%atom(iatom,1:3) - if(all(abs(ttrans(1:3)-anint(ttrans(1:3))).lt.tol_sym)) cycle trloop - if(confine%l)then - if(confine%laxis(confine%axis).and.& - abs(ttrans(confine%axis)-nint(ttrans(confine%axis)))& - .gt.tol_sym) cycle trloop - end if - itmp1 = 0 - sav_trans = 0.D0 - if(lwyckoff.and.ntrans+1.gt.size(wyck_check))then - write(0,'("ERROR: error encountered in gldfnd")') - write(0,'(2X,"Internal error in subroutine gldfnd in mod_sym.f90")') - write(0,'(2X,"ntrans is greater than wyck_check")') - write(0,'(2X,"EXITING SUBROUTINE")') - return - end if - trcyc: do ispec=1,bas%nspec - samecount=0 - if(lwyckoff) wyck_check(ntrans+1)%spec(ispec)%atom(:) = 0 - atmcyc2: do jatom=1,bas%spec(ispec)%num - itmp1 = itmp1 + 1 - tmpbas(1:3) = tfbas%spec(ispec)%atom(jatom,1:3) + ttrans(1:3) - tmpbas(:) = tmpbas(:) - ceiling(tmpbas(:)-0.5D0) - atmcyc3: do katom=1,bas%spec(ispec)%num - !if(lwyckoff.and.& - ! wyck_check(ntrans+1)%spec(ispec)%atom(katom).ne.0) & - ! cycle atmcyc3 - diff = tmpbas(1:3) - bas%spec(ispec)%atom(katom,1:3) - do j=1,3 - diff(j) = mod((diff(j)+100.D0),1.0) - if((abs(diff(j)-1.D0)).lt.(tol_sym)) diff(j) = 0.D0 - end do - if(sqrt(dot_product(diff,diff)).lt.tol_sym)then - samecount = samecount + 1 - !sav_trans(itmp1,:)=bas%spec(ispec)%atom(jatom,1:3)-& - ! bas%spec(ispec)%atom(katom,1:3) - sav_trans(itmp1,:) = bas%spec(ispec)%atom(katom,1:3) - & - tfbas%spec(ispec)%atom(jatom,1:3) - sav_trans(itmp1,:) = sav_trans(itmp1,:) - & - ceiling(sav_trans(itmp1,:)-0.5D0) - if(lwyckoff) & - wyck_check(ntrans+1)%spec(ispec)%atom(jatom) = katom - cycle atmcyc2 - end if - end do atmcyc3 - !cycle trloop - end do atmcyc2 - if (samecount.ne.bas%spec(ispec)%num) cycle trloop - end do trcyc -!!!----------------------------------------------------------------------------- -!!! Cleans up succeeded translation vector -!!!----------------------------------------------------------------------------- - do j=1,3 - itmp1 = maxloc(abs(sav_trans(:,j)),dim=1) - ttrans(j) = sav_trans(itmp1,j) - ttrans(j) = ttrans(j) - ceiling(ttrans(j)-0.5D0) - end do -!!!----------------------------------------------------------------------------- -!!! If axis is confined, removes all symmetries not confined to the axis plane -!!!----------------------------------------------------------------------------- - if(confine%l)then - if(confine%laxis(confine%axis).and.& - abs(ttrans(confine%axis)-nint(ttrans(confine%axis)))& - .gt.tol_sym) cycle trloop - else - do i=1,3 - if(confine%laxis(i))then - if(abs(ttrans(confine%axis)-floor(ttrans(confine%axis)))& - .lt.tol_sym) cycle trloop - end if - end do - end if -!!!----------------------------------------------------------------------------- -!!! Checks whether this translation has already been saved -!!!----------------------------------------------------------------------------- - do i=1,ntrans - if(all(ttrans(:).eq.trans(i,:))) cycle trloop - !if(all(abs(ttrans(:)-trans(i,:)).lt.tol_sym)) cycle trloop - end do - ntrans = ntrans + 1 - trans(ntrans,1:3) = ttrans(1:3) - if(confine%l) return - end do trloop - - - return - end subroutine gldfnd -!!!############################################################################# - - -!!!############################################################################# -!!! builds an array of the symmetries that apply to the supplied lattice -!!!############################################################################# - subroutine gen_fundam_sym_matrices(grp,lat) - implicit none - integer :: i - type(sym_type) :: grp - double precision :: cosPi3,sinPi3,mcosPi3,msinPi3 - double precision, dimension(3,3) :: inversion,invlat,tmat1 - double precision, dimension(64,3,3) :: fundam_mat - double precision, dimension(3,3), intent(in) :: lat - - - cosPi3 = 0.5D0 - sinPi3 = sin(pi/3.D0) - mcosPi3 = -cosPi3 - msinPi3 = -sinPi3 - - - fundam_mat(1,1:3,1:3)=transpose(reshape((/& - 1.D0, 0.D0, 0.D0, 0.D0, 1.D0, 0.D0, 0.D0, 0.D0, 1.D0 /),& - shape(inversion))) - - fundam_mat(2,1:3,1:3)=transpose(reshape((/& - -1.D0, 0.D0, 0.D0, 0.D0, -1.D0, 0.D0, 0.D0, 0.D0, 1.D0 /),& - shape(inversion))) - - fundam_mat(3,1:3,1:3)=transpose(reshape((/& - -1.D0, 0.D0, 0.D0, 0.D0, 1.D0, 0.D0, 0.D0, 0.D0, -1.D0 /),& - shape(inversion))) - - fundam_mat(4,1:3,1:3)=transpose(reshape((/& - 1.D0, 0.D0, 0.D0, 0.D0, -1.D0, 0.D0, 0.D0, 0.D0, -1.D0 /),& - shape(inversion))) - - fundam_mat(5,1:3,1:3)=transpose(reshape((/& - 0.D0, 1.D0, 0.D0, 1.D0, 0.D0, 0.D0, 0.D0, 0.D0, -1.D0 /),& - shape(inversion))) - - fundam_mat(6,1:3,1:3)=transpose(reshape((/& - 0.D0, -1.D0, 0.D0, -1.D0, 0.D0, 0.D0, 0.D0, 0.D0, -1.D0 /),& - shape(inversion))) - - fundam_mat(7,1:3,1:3)=transpose(reshape((/& - 0.D0, -1.D0, 0.D0, 1.D0, 0.D0, 0.D0, 0.D0, 0.D0, 1.D0 /),& - shape(inversion))) - - fundam_mat(8,1:3,1:3)=transpose(reshape((/& - 0.D0, 1.D0, 0.D0, -1.D0, 0.D0, 0.D0, 0.D0, 0.D0, 1.D0 /),& - shape(inversion))) - - fundam_mat(9,1:3,1:3)=transpose(reshape((/& - 0.D0, 0.D0, 1.D0, 0.D0, -1.D0, 0.D0, 1.D0, 0.D0, 0.D0 /),& - shape(inversion))) - - fundam_mat(10,1:3,1:3)=transpose(reshape((/& - 0.D0, 0.D0, -1.D0, 0.D0, -1.D0, 0.D0, -1.D0, 0.D0, 0.D0 /),& - shape(inversion))) - - fundam_mat(11,1:3,1:3)=transpose(reshape((/& - 0.D0, 0.D0, -1.D0, 0.D0, 1.D0, 0.D0, 1.D0, 0.D0, 0.D0 /),& - shape(inversion))) - - fundam_mat(12,1:3,1:3)=transpose(reshape((/& - 0.D0, 0.D0, 1.D0, 0.D0, 1.D0, 0.D0, -1.D0, 0.D0, 0.D0 /),& - shape(inversion))) - - fundam_mat(13,1:3,1:3)=transpose(reshape((/& - -1.D0, 0.D0, 0.D0, 0.D0, 0.D0, 1.D0, 0.D0, 1.D0, 0.D0 /),& - shape(inversion))) - - fundam_mat(14,1:3,1:3)=transpose(reshape((/& - -1.D0, 0.D0, 0.D0, 0.D0, 0.D0, -1.D0, 0.D0, -1.D0, 0.D0 /),& - shape(inversion))) - - fundam_mat(15,1:3,1:3)=transpose(reshape((/& - 1.D0, 0.D0, 0.D0, 0.D0, 0.D0, -1.D0, 0.D0, 1.D0, 0.D0 /),& - shape(inversion))) - - fundam_mat(16,1:3,1:3)=transpose(reshape((/& - 1.D0, 0.D0, 0.D0, 0.D0, 0.D0, 1.D0, 0.D0, -1.D0, 0.D0/),& - shape(inversion))) - - fundam_mat(17,1:3,1:3)=transpose(reshape((/& - 0.D0, 0.D0, 1.D0, 1.D0, 0.D0, 0.D0, 0.D0, 1.D0, 0.D0 /),& - shape(inversion))) - - fundam_mat(18,1:3,1:3)=transpose(reshape((/& - 0.D0, 0.D0, -1.D0, -1.D0, 0.D0, 0.D0, 0.D0, 1.D0, 0.D0 /),& - shape(inversion))) - - fundam_mat(19,1:3,1:3)=transpose(reshape((/& - 0.D0, 0.D0, -1.D0, 1.D0, 0.D0, 0.D0, 0.D0, -1.D0, 0.D0 /),& - shape(inversion))) - - fundam_mat(20,1:3,1:3)=transpose(reshape((/& - 0.D0, 0.D0, 1.D0, -1.D0, 0.D0, 0.D0, 0.D0, -1.D0, 0.D0 /),& - shape(inversion))) - - fundam_mat(21,1:3,1:3)=transpose(reshape((/& - 0.D0, 1.D0, 0.D0, 0.D0, 0.D0, 1.D0, 1.D0, 0.D0, 0.D0 /),& - shape(inversion))) - - fundam_mat(22,1:3,1:3)=transpose(reshape((/& - 0.D0, -1.D0, 0.D0, 0.D0, 0.D0, -1.D0, 1.D0, 0.D0, 0.D0 /),& - shape(inversion))) - - fundam_mat(23,1:3,1:3)=transpose(reshape((/& - 0.D0, -1.D0, 0.D0, 0.D0, 0.D0, 1.D0, -1.D0, 0.D0, 0.D0 /),& - shape(inversion))) - - fundam_mat(24,1:3,1:3)=transpose(reshape((/& - 0.D0, 1.D0, 0.D0, 0.D0, 0.D0, -1.D0, -1.D0, 0.D0, 0.D0 /),& - shape(inversion))) - - fundam_mat(25,1:3,1:3)=transpose(reshape((/& - cosPi3, sinPi3, 0.D0, msinPi3, cosPi3, 0.D0, 0.D0, 0.D0, 1.D0 /),& - shape(inversion))) - - fundam_mat(26,1:3,1:3)=transpose(reshape((/& - cosPi3, msinPi3, 0.D0, sinPi3, cosPi3, 0.D0, 0.D0, 0.D0, 1.D0 /),& - shape(inversion))) - - fundam_mat(27,1:3,1:3)=transpose(reshape((/& - mcosPi3, sinPi3, 0.D0, msinPi3, mcosPi3, 0.D0, 0.D0, 0.D0, 1.D0 /),& - shape(inversion))) - - fundam_mat(28,1:3,1:3)=transpose(reshape((/& - mcosPi3, msinPi3, 0.D0, sinPi3, mcosPi3, 0.D0, 0.D0, 0.D0, 1.D0 /),& - shape(inversion))) - - fundam_mat(29,1:3,1:3)=transpose(reshape((/& - cosPi3, msinPi3, 0.D0, msinPi3, mcosPi3, 0.D0, 0.D0, 0.D0, -1.D0 /),& - shape(inversion))) - - fundam_mat(30,1:3,1:3)=transpose(reshape((/& - cosPi3, sinPi3, 0.D0, sinPi3, mcosPi3, 0.D0, 0.D0, 0.D0, -1.D0 /),& - shape(inversion))) - - fundam_mat(31,1:3,1:3)=transpose(reshape((/& - mcosPi3, msinPi3, 0.D0, msinPi3, cosPi3, 0.D0, 0.D0, 0.D0, -1.D0 /),& - shape(inversion))) - - fundam_mat(32,1:3,1:3)=transpose(reshape((/& - mcosPi3, sinPi3, 0.D0, sinPi3, cosPi3, 0.D0, 0.D0, 0.D0, -1.D0 /),& - shape(inversion))) - - inversion(:3,:3)=transpose(reshape((/& - -1.D0, 0.D0, 0.D0, 0.D0, -1.D0, 0.D0, 0.D0, 0.D0, -1.D0 /),& - shape(inversion))) - - - do i=1,32 - fundam_mat(i+32,:3,:3) = matmul(inversion,fundam_mat(i,:3,:3)) - end do - - - grp%nsym=0 - invlat=inverse_3x3(lat) - do i=1,64 - tmat1=matmul(lat,fundam_mat(i,:3,:3)) - tmat1=matmul(tmat1,(invlat)) - !! ensure that the matrix preserves size of 1 - !! this is likely redundant - if(abs(abs(det(tmat1))-1.D0).gt.tol_sym) cycle - if(all(abs(tmat1-nint(tmat1)).le.tol_sym))then - grp%nsym=grp%nsym+1 - fundam_mat(grp%nsym,:,:)=fundam_mat(i,:,:) - end if - end do - - - allocate(grp%sym(grp%nsym,4,4)) - grp%sym(:,:,:)=0.D0 - grp%sym(:,4,4)=1.D0 - grp%sym(:grp%nsym,:3,:3)=fundam_mat(:grp%nsym,:3,:3) - grp%nlatsym=grp%nsym - - - !! REDUCE THIS SET BY DOING LTL^-1 AND JUST CHECK IF ANY BECOME NON-ZERO - !! IF ONE DOES, SCRAP IT - !! IF ONE DOESN'T, SAVE THE ORIGINAL (NOT THE NEWLY CREATED ONE) - - - end subroutine gen_fundam_sym_matrices -!!!############################################################################# - - -!!!############################################################################# -!!! builds an array of the symmetries that apply to the supplied lattice -!!!############################################################################# - subroutine mksym(grp,inlat) - implicit none - integer :: amin,bmin,cmin - integer :: i,j,ia,ib,ic,n,count,irot,nrot,isym,jsym - double precision :: tht,a,b,c - type(sym_type) :: grp - double precision, dimension(3,3) :: rotmat,refmat,inlat,lat,invlat,tmat1 - double precision, allocatable, dimension(:,:,:) :: tsym1,tsym2 - logical, dimension(3) :: laxis - - - if(grp%confine%l)then - laxis=grp%confine%laxis - else - laxis=.not.grp%confine%laxis - end if - - -!!!----------------------------------------------------------------------------- -!!! set up inverse lattice -!!!----------------------------------------------------------------------------- - lat=inlat - if(grp%lmolec)then - invlat=0.D0 - lat=0.D0 - else - invlat=inverse_3x3(lat) - end if - - -!!!----------------------------------------------------------------------------- -!!! initialise values and symmetry matrix -!!!----------------------------------------------------------------------------- - allocate(tsym1(50000,4,4)) - tsym1=0.D0 - tsym1(:,4,4)=1.D0 - count=0 - - -!!!----------------------------------------------------------------------------- -!!! rotation plane perp to z (1=E,2=C2,3=C3,4=C4,5=C5,6=C6) -!!!----------------------------------------------------------------------------- - if(laxis(3))then - mksyml: do n=1,10 - count=count+1 - if(n.gt.6)then - tht = -2.D0*pi/real(n-4) !=2*pi/(n-4) - else - tht = 2.D0*pi/real(n) !=2*pi/n - end if - tsym1(count,1:3,1:3)=transpose(reshape((/& - cos(tht) , sin(tht), 0.D0,& - -sin(tht), cos(tht), 0.D0,& - 0.D0 , 0.D0, 1.D0/), shape(rotmat))) - do i=1,3 - do j=1,3 - if(abs(tsym1(count,i,j)).lt.tol_sym) tsym1(count,i,j)=0.D0 - end do - end do - end do mksyml - nrot=count - end if - - -!!!----------------------------------------------------------------------------- -!!! rotation plane perp to x -!!!----------------------------------------------------------------------------- - if(laxis(1))then - philoop: do n=1,10 - if(n.gt.6)then - tht = -2.D0*pi/real(n-4) !=2*pi/n - else - tht = 2.D0*pi/real(n) !=2*pi/n - end if - rotmat=transpose(reshape((/& - 1.D0, 0.D0, 0.D0, & - 0.D0, cos(tht), sin(tht),& - 0.D0, -sin(tht), cos(tht)/), shape(rotmat))) - rot2: do irot=1,nrot - count=count+1 - tsym1(count,1:3,1:3)=matmul(rotmat(1:3,1:3),tsym1(irot,1:3,1:3)) - end do rot2 - end do philoop - nrot=count - end if - - -!!!----------------------------------------------------------------------------- -!!! rotation plane perp to y -!!!----------------------------------------------------------------------------- - if(laxis(2))then - psiloop: do n=1,10 - if(n.gt.6)then - tht = -2.D0*pi/real(n-4) !=2*pi/n - else - tht = 2.D0*pi/real(n) !=2*pi/n - end if - rotmat=transpose(reshape((/& - cos(tht) , 0.D0, sin(tht),& - 0.D0 , 1.D0, 0.D0, & - -sin(tht), 0.D0, cos(tht)/), shape(rotmat))) - rot3: do irot=1,nrot - count=count+1 - tsym1(count,1:3,1:3)=matmul(rotmat(1:3,1:3),tsym1(irot,1:3,1:3)) - do i=1,3 - do j=1,3 - if(abs(tsym1(count,i,j)).lt.tol_sym) tsym1(count,i,j)=0.D0 - end do - end do - end do rot3 - end do psiloop - nrot=count - end if - - -!!!----------------------------------------------------------------------------- -!!! inversion (i), x plane mirror (v), y plane mirror (v), z plane mirror (h) -!!!----------------------------------------------------------------------------- - amin=1;bmin=1;cmin=1 - if(grp%confine%lmirror)then - if(laxis(1)) amin=2 - if(laxis(2)) bmin=2 - if(laxis(3)) cmin=2 - end if - aloop: do ia=amin,2 - a=(-1.D0)**ia - bloop: do ib=bmin,2 - b=(-1.D0)**ib - cloop: do ic=cmin,2 - c=(-1.D0)**ic - ! if((a*b*c).ne.(-1.D0)) cycle cloop - refmat(1:3,1:3)=transpose(reshape((/& - a, 0.D0, 0.D0,& - 0.D0, b , 0.D0,& - 0.D0, 0.D0, c/), shape(rotmat))) - refloop: do irot=1,nrot - count=count+1 - tsym1(count,1:3,1:3)=matmul(refmat(1:3,1:3),tsym1(irot,1:3,1:3)) - end do refloop - end do cloop - end do bloop - end do aloop - grp%nsym=count - - - if(grp%lmolec)then - allocate(grp%sym(grp%nsym,4,4)) - grp%sym(:grp%nsym,:,:)=tsym1(:grp%nsym,:,:) - deallocate(tsym1) - return - end if - !! best so far - ! sym(isym,1:3,1:3)=matmul(transpose(lat),sym(isym,1:3,1:3)) - ! sym(isym,1:3,1:3)=matmul(sym(isym,1:3,1:3),(invlat)) -!!!----------------------------------------------------------------------------- -!!! checks all made symmetries to see if they apply to the supplied lattice -!!!----------------------------------------------------------------------------- - allocate(tsym2(grp%nsym,4,4)) - tsym2=0.D0 - tsym2(:,4,4)=1.D0 - count=0 - samecheck: do isym=1,grp%nsym - tmat1=matmul((lat),tsym1(isym,:3,:3)) - tmat1=matmul(tmat1,(invlat)) - do i=1,3 - do j=1,3 - if(abs(tmat1(i,j)).lt.tol_sym) tmat1(i,j)=0.D0 - if(abs(1.D0-abs(tmat1(i,j))).lt.tol_sym) & - tmat1(i,j)=sign(1.D0,tmat1(i,j)) - end do - end do - !!----------------------------------------------------------------------- - !! Precautionary measure - if(all(abs(tmat1).lt.tol_sym)) cycle samecheck - if(abs(abs(det(tmat1))-1.D0).gt.tol_sym) cycle samecheck - !!----------------------------------------------------------------------- - if(.not.all(abs(tmat1-nint(tmat1)).lt.tol_sym)) cycle samecheck - do jsym=1,count - if(all(tmat1.eq.tsym2(jsym,:3,:3))) cycle samecheck - !if(all(tsym1(isym,:3,:3).eq.tsym2(jsym,:3,:3))) cycle samecheck - end do - count=count+1 - tsym2(count,:3,:3)=tmat1 - !tsym2(count,:4,:4)=tsym1(isym,:4,:4) - end do samecheck - grp%nsym=count - deallocate(tsym1) - allocate(grp%sym(grp%nsym,4,4)) - grp%sym(:grp%nsym,:4,:4)=tsym2(:grp%nsym,:4,:4) - deallocate(tsym2) - - grp%nlatsym=grp%nsym - - - return - end subroutine mksym -!!!############################################################################# - - -!!!############################################################################# -!!! clone ingrp to outgrp -!!!############################################################################# - subroutine clone_grp(ingrp,outgrp) - implicit none - type(sym_type), intent(in) :: ingrp - type(sym_type), intent(out) :: outgrp - - - allocate(outgrp%op(size(ingrp%op))) - allocate(outgrp%sym(size(ingrp%sym(:,1,1)),4,4)) - outgrp = ingrp - - end subroutine clone_grp -!!!############################################################################# - - -!!!############################################################################# -!!! returns the primitive cell from a supercell -!!!############################################################################# - subroutine get_primitive_cell(lat,bas) - implicit none - integer :: is,ia,ja,i,j,k,itmp1 - integer :: ntrans,len - double precision :: scale,proj,dtmp1 - type(confine_type) :: confine - double precision, dimension(3,3) :: dmat1,invlat - double precision, allocatable, dimension(:,:) :: trans,atom_store - - type(sym_type) :: grp - type(bas_type) :: bas,pbas - double precision, dimension(3,3) :: lat - - - !!----------------------------------------------------------------------- - !! Allocate and initialise - !!----------------------------------------------------------------------- - ntrans = 0 - dmat1=0.D0 - allocate(trans(minval(bas%spec(:)%num+2),3)); trans=0.D0 - - - !!----------------------------------------------------------------------- - !! Find the translation vectors in the cell - !!----------------------------------------------------------------------- - call gldfnd(confine,bas,bas,trans,ntrans,.false.) - len=size(bas%spec(1)%atom,dim=2) - - - !!----------------------------------------------------------------------- - !! For each translation, reduce the basis - !!----------------------------------------------------------------------- - if(ntrans.ge.1)then - do i=ntrans+1,ntrans+3 - trans(i,:)=0.D0 - trans(i,i-ntrans)=1.D0 - end do - ! trans=matmul(trans(1:ntrans,1:3),lat) - call sort2D(trans(1:ntrans+3,:),ntrans+3) - !! for each lattice vector, determine the shortest translation ... - !! ... vector that has a non-zero projection along that lattice vector. - do i=1,3 - proj=1.D2 - trans_loop: do j=1,ntrans+3 - dtmp1 = dot_product(trans(j,:),trans(ntrans+i,:)) - if(dtmp1.lt.tol_sym) cycle trans_loop - - do k=1,i-1,1 - if(modu(abs(cross(trans(j,:),dmat1(k,:)))).lt.1.D-8) cycle trans_loop - end do - - dtmp1 = modu(trans(j,:)) - if(dtmp1.lt.proj)then - proj=dtmp1 - dmat1(i,:) = trans(j,:) - trans(j,:) = 0.D0 - end if - end do trans_loop - end do - !dmat1=trans(1:3,1:3) - scale=det(dmat1) - dmat1=matmul(dmat1,lat) - invlat=inverse_3x3(dmat1) - do is=1,bas%nspec - itmp1=0 - allocate(atom_store(nint(scale*bas%spec(is)%num),len)) - atcheck: do ia=1,bas%spec(is)%num - !!----------------------------------------------------------------- - !! Reduce the basis - !!----------------------------------------------------------------- - bas%spec(is)%atom(ia,1:3)=& - matmul(bas%spec(is)%atom(ia,1:3),lat(1:3,1:3)) - bas%spec(is)%atom(ia,1:3)=& - matmul(transpose(invlat(1:3,1:3)),bas%spec(is)%atom(ia,1:3)) - do j=1,3 - bas%spec(is)%atom(ia,j)=& - bas%spec(is)%atom(ia,j)-floor(bas%spec(is)%atom(ia,j)) - if(bas%spec(is)%atom(ia,j).gt.1.D0-tol_sym) & - bas%spec(is)%atom(ia,j)=0.D0 - end do - !!----------------------------------------------------------------- - !! Check for duplicates in the cell - !!----------------------------------------------------------------- - do ja=1,ia-1 - if(all(abs(bas%spec(is)%atom(ia,1:3)-atom_store(ja,1:3)).lt.& - (/tol_sym,tol_sym,tol_sym/))) cycle atcheck - end do - itmp1=itmp1+1 - atom_store(itmp1,:)=bas%spec(is)%atom(ia,:) - !!----------------------------------------------------------------- - !! Check to ensure correct number of atoms remain after reduction - !!----------------------------------------------------------------- - if(itmp1.gt.size(atom_store,dim=1))then - write(0,*) "ERROR! Primitive cell subroutine retained too & - &many atoms from supercell!", itmp1, size(atom_store,dim=1) - call exit() - end if - !!----------------------------------------------------------------- - end do atcheck - deallocate(bas%spec(is)%atom) - call move_alloc(atom_store,bas%spec(is)%atom) - bas%spec(is)%num=size(bas%spec(is)%atom,dim=1) - !deallocate(atom_store) - end do - !!----------------------------------------------------------------------- - !! Reduce the lattice - !!----------------------------------------------------------------------- - bas%natom=sum(bas%spec(:)%num) - lat=dmat1 - end if - - - !!----------------------------------------------------------------------- - !! Reduce the lattice to symmetry definition - !!----------------------------------------------------------------------- - call reducer(lat, bas) - !! next line necessary as FCC and BCC do not conform to Niggli reduced ... - !! ... cell definitions. - lat = primitive_lat(lat) - - - - end subroutine get_primitive_cell -!!!############################################################################# - - -!!!############################################################################# -!!! takes in transformation matrix and outputs its (x,y,z) definition -!!!############################################################################# - subroutine symwrite (sym,symchar) - implicit none - integer :: i,j,nt,nr,div - double precision, dimension(4,4) :: sym - character(1024) :: symchar - character(2) :: rm,c - character(1), dimension(3) :: xyz - - xyz(1)="x";xyz(2)="y";xyz(3)="z" - symchar="" - do i=1,3 - select case (nint(100*sym(4,i))) - case(0) - case default - div=abs(gcd(nint(100*sym(4,i)),100)) - write(symchar,'(A,I0,"aa",I0)') trim(symchar),nint(100*sym(4,i))/div,100/div - end select - - do j=1,3 - select case (int(sym(j,i))) - case(0) - cycle - case(1) - c="" - case default - write(c,"(I2)") int(sym(j,i)) - end select - symchar=trim(symchar) //"+"//trim(adjustl(c(1:1)))//xyz(j) - end do - if(i.ne.3) symchar=trim(symchar) //"," - end do - - rm="+-" - nt=len_trim(symchar) ; nr=len_trim(symchar) - remove: do - i=index(symchar,trim(adjustl(rm))) - if(i.eq.0) exit remove - symchar = symchar(:i-1) //symchar(i+1:nt) - end do remove - - rm=",+" - nt=len_trim(symchar) ; nr=len_trim(symchar) - remove2: do - i=index(symchar,trim(adjustl(rm))) - if(i.eq.0) exit remove2 - symchar = symchar(:i) //symchar(i+2:nt) - end do remove2 - if(symchar(:1).eq."+") symchar=symchar(2:) - - rm="aa" - nt=len_trim(symchar) ; nr=len_trim(symchar) - remove3: do - i=index(symchar,trim(adjustl(rm))) - if(i.eq.0) exit remove3 - symchar = symchar(:i-1) //"/"//symchar(i+2:nt) - end do remove3 - - - symchar = "("//trim(adjustl(symchar))//")" - write(77,*) trim(adjustl(symchar)) - - end subroutine symwrite -!!!############################################################################# - - -!!!############################################################################# -!!! returns the wyckoff atoms of a basis (closest to a defined location) -!!!############################################################################# - function get_wyckoff_atoms_any(wyckoff) result(wyckoff_atoms) - implicit none - integer :: i,is,ia,isym,imin,itmp1 - integer :: nsym,nspec - type(wyck_type) :: wyckoff_atoms - integer, allocatable, dimension(:) :: ivtmp1 - - type(wyck_type), dimension(:), intent(in) :: wyckoff - - - nsym = size(wyckoff) - nspec = size(wyckoff(1)%spec(:)) - allocate(wyckoff_atoms%spec(nspec)) - wyckoff_atoms%spec(:)%num = 0 - do is=1,nspec - allocate(ivtmp1(size(wyckoff(1)%spec(is)%atom))) - ivtmp1 = 0 - do ia=1,size(wyckoff(1)%spec(is)%atom) - - imin = wyckoff(1)%spec(is)%atom(ia) - if(imin.eq.0)then - write(0,'("ERROR: imin in get_wyckoff_atoms is zero!!!")') - write(0,'("Exiting...")') - stop - end if - sym_loop1: do isym=2,nsym - if(wyckoff(isym)%spec(is)%atom(ia).eq.0) cycle sym_loop1 - if(wyckoff(isym)%spec(is)%atom(ia).lt.imin)& - imin = wyckoff(isym)%spec(is)%atom(ia) - end do sym_loop1 - sym_loop2: do - itmp1 = minval( (/ (wyckoff(i)%spec(is)%atom(imin),i=1,nsym) /),& - mask=(/ (wyckoff(i)%spec(is)%atom(imin),i=1,nsym) /).gt.0 ) - if(itmp1.ne.imin)then - imin=itmp1 - else - exit sym_loop2 - end if - end do sym_loop2 - - if(.not.any(ivtmp1(:).eq.imin))then - wyckoff_atoms%spec(is)%num = wyckoff_atoms%spec(is)%num+1 - ivtmp1(wyckoff_atoms%spec(is)%num) = imin - end if - - end do - allocate(wyckoff_atoms%spec(is)%atom(wyckoff_atoms%spec(is)%num)) - wyckoff_atoms%spec(is)%atom(:)=ivtmp1(:wyckoff_atoms%spec(is)%num) - deallocate(ivtmp1) - end do - wyckoff_atoms%nwyck = sum(wyckoff_atoms%spec(:)%num) - - - end function get_wyckoff_atoms_any -!!!----------------------------------------------------------------------------- -!!!----------------------------------------------------------------------------- - function get_wyckoff_atoms_loc(wyckoff,lat,bas,loc) result(wyckoff_atoms) - implicit none - integer :: i,is,ia,isym,imin,itmp1 - integer :: nsym - double precision :: dist - logical :: lfound_closer - type(wyck_type) :: wyckoff_atoms - double precision, dimension(3) :: diff - double precision, allocatable, dimension(:) :: dists - integer, allocatable, dimension(:) :: ivtmp1 - - type(bas_type), intent(in) :: bas - double precision, dimension(3), intent(in) :: loc - type(wyck_type), dimension(:), intent(in) :: wyckoff - double precision, dimension(3,3), intent(in) :: lat - - - nsym = size(wyckoff) - allocate(wyckoff_atoms%spec(bas%nspec)) - wyckoff_atoms%spec(:)%num = 0 - do is=1,bas%nspec - allocate(ivtmp1(size(wyckoff(1)%spec(is)%atom))) - ivtmp1 = 0 - - allocate(dists(bas%spec(is)%num)) - do ia=1,bas%spec(is)%num - diff = loc - bas%spec(is)%atom(ia,:3) - diff = diff - ceiling(diff - 0.5D0) - dists(ia) = modu(matmul(diff,lat)) - end do - - wyckoff_loop1: do ia=1,size(wyckoff(1)%spec(is)%atom) - - dist = huge(0.D0) - imin = wyckoff(1)%spec(is)%atom(ia) - sym_loop1: do isym=1,nsym - if(wyckoff(isym)%spec(is)%atom(ia).eq.0) cycle sym_loop1 - - if(dists(wyckoff(isym)%spec(is)%atom(ia)).lt.dist)then - dist = dists(wyckoff(isym)%spec(is)%atom(ia)) - imin = wyckoff(isym)%spec(is)%atom(ia) - end if - end do sym_loop1 - if(any(ivtmp1(:).eq.imin)) cycle wyckoff_loop1 - - sym_loop2: do - lfound_closer = .false. - sym_loop3: do isym=1,nsym - if(wyckoff(isym)%spec(is)%atom(imin).eq.0) cycle sym_loop3 - if(wyckoff(isym)%spec(is)%atom(imin).eq.imin) cycle sym_loop3 - if(dists(wyckoff(isym)%spec(is)%atom(imin)).lt.dist)then - dist = dists(wyckoff(isym)%spec(is)%atom(imin)) - itmp1 = wyckoff(isym)%spec(is)%atom(imin) - lfound_closer = .true. - elseif(dists(wyckoff(isym)%spec(is)%atom(imin)).eq.dist)then - if(any(ivtmp1(:).eq.wyckoff(isym)%spec(is)%atom(imin)))then - dist = dists(wyckoff(isym)%spec(is)%atom(imin)) - itmp1 = wyckoff(isym)%spec(is)%atom(imin) - lfound_closer = .true. - end if - end if - end do sym_loop3 - if(lfound_closer)then - imin = itmp1 - else - exit sym_loop2 - end if - end do sym_loop2 - - - if(.not.any(ivtmp1(:).eq.imin))then - wyckoff_atoms%spec(is)%num = wyckoff_atoms%spec(is)%num+1 - ivtmp1(wyckoff_atoms%spec(is)%num) = imin - end if - if(imin.eq.0)then - write(0,'("ERROR: imin in get_wyckoff_atoms is zero!!!")') - write(0,'("Exiting...")') - stop - end if - - end do wyckoff_loop1 - allocate(wyckoff_atoms%spec(is)%atom(wyckoff_atoms%spec(is)%num)) - wyckoff_atoms%spec(is)%atom(:)=ivtmp1(:wyckoff_atoms%spec(is)%num) - deallocate(ivtmp1) - deallocate(dists) - end do - wyckoff_atoms%nwyck = sum(wyckoff_atoms%spec(:)%num) - - - end function get_wyckoff_atoms_loc -!!!############################################################################# - - -!!!############################################################################# -!!! find corresponding basis2 atoms that the supplied symmetry operation ... -!!! ... maps basis1 atoms onto. -!!! Basis2 is optional. If missing, it uses basis1 for the comparison -!!!############################################################################# - function basis_map(sym,bas1,tmpbas2) result(bas_map) - implicit none - integer :: j,ispec,iatom,jatom,dim - type(basmap_type) :: bas_map - type(bas_type) :: bas2,tfbas - double precision, dimension(3) :: diff - type(bas_type), intent(in) :: bas1 - double precision, dimension(4,4), intent(in) :: sym - type(bas_type), optional, intent(in) :: tmpbas2 - - -!!!----------------------------------------------------------------------------- -!!! checks for optional arguments and assigns values if not present -!!!----------------------------------------------------------------------------- - allocate(bas2%spec(bas1%nspec)) - dim=size(bas1%spec(1)%atom(1,:),dim=1) - do ispec=1,bas1%nspec - allocate(bas2%spec(ispec)%atom(bas1%spec(ispec)%num,dim)) - end do - if(present(tmpbas2)) then - bas2 = tmpbas2 - else - bas2 = bas1 - end if - - -!!!----------------------------------------------------------------------------- -!!! sets up basis map -!!!----------------------------------------------------------------------------- - allocate(bas_map%spec(bas1%nspec)) - do ispec=1,bas1%nspec - allocate(bas_map%spec(ispec)%atom(bas1%spec(ispec)%num)) - bas_map%spec(ispec)%atom(:)=0 - end do - allocate(tfbas%spec(bas1%nspec)) - do ispec=1,bas1%nspec - allocate(tfbas%spec(ispec)%atom(bas1%spec(ispec)%num,4)) - end do - - -!!!----------------------------------------------------------------------------- -!!! apply symmetry operator to bas1 -!!!----------------------------------------------------------------------------- - do ispec=1,bas1%nspec - do iatom=1,bas1%spec(ispec)%num - tfbas%spec(ispec)%atom(iatom,1:3) = & - matmul(bas1%spec(ispec)%atom(iatom,1:4),sym(1:4,1:3)) - do j=1,3 - tfbas%spec(ispec)%atom(iatom,j) = & - tfbas%spec(ispec)%atom(iatom,j) - & - ceiling(tfbas%spec(ispec)%atom(iatom,j) - 0.5D0) - bas2%spec(ispec)%atom(iatom,j) = & - bas2%spec(ispec)%atom(iatom,j) - & - ceiling(bas2%spec(ispec)%atom(iatom,j) - 0.5D0) - end do - end do - end do - - -!!!----------------------------------------------------------------------------- -!!! check whether transformed basis matches original basis -!!!----------------------------------------------------------------------------- - spcheck2: do ispec=1,bas1%nspec - diff=0.D0 - atmcheck2: do iatom=1,bas1%spec(ispec)%num - atmcyc2: do jatom=1,bas1%spec(ispec)%num - if(any(bas_map%spec(ispec)%atom(:).eq.jatom)) cycle atmcyc2 - diff = tfbas%spec(ispec)%atom(iatom,1:3) - & - bas2%spec(ispec)%atom(jatom,1:3) - diff = diff - ceiling(diff - 0.5D0) - if(sqrt(dot_product(diff,diff)).lt.tol_sym)then - bas_map%spec(ispec)%atom(iatom) = jatom - end if - end do atmcyc2 - end do atmcheck2 - end do spcheck2 - - - return - end function basis_map -!!!############################################################################# - - -!!!############################################################################# -!!! finds all possible terminations along an axis -!!!############################################################################# - function get_terminations(lat,bas,axis,lprint,layer_sep) result(term) - implicit none - integer :: i,j,k,is,nterm,mterm,dim,ireject - integer :: itmp1,itmp2,init,min_loc - logical :: ludef_print,lunique,ltmp1,lmirror - double precision :: dtmp1,tol,height,max_sep,c_along,centre - type(sym_type) :: grp1,grp_store, grp_store_inv - type(term_arr_type) :: term - integer, dimension(3) :: abc=(/1,2,3/) - double precision, dimension(3) :: vec_compare,vtmp1 - double precision, dimension(3,3) :: inv_mat,ident - type(bas_type),allocatable, dimension(:) :: bas_arr,bas_arr_reject - type(term_type), allocatable, dimension(:) :: term_arr,term_arr_uniq - integer, allocatable, dimension(:) :: success,tmpop - integer, allocatable, dimension(:,:) :: reject_match - double precision, allocatable, dimension(:,:) :: bas_list - double precision, allocatable, dimension(:,:,:) :: tmpsym - - integer, intent(in) :: axis - type(bas_type), intent(in) :: bas - double precision, dimension(3,3), intent(in) :: lat - - double precision, optional, intent(in) :: layer_sep - logical, optional, intent(in) :: lprint - - integer, dimension(:), allocatable :: comparison_list - - - -!!!APPLY TRANSFORMATION MATRIX TO FIND TERMINATIONS ALONG OTHER PLANES -!!! E.G. (1 0 1) - - s_end=0 - grp_store%confine%l=.false. - grp_store%confine%axis=axis - grp_store%confine%laxis=.false. -!!!----------------------------------------------------------------------------- -!!! Sets printing option -!!!----------------------------------------------------------------------------- - if(present(lprint))then - ludef_print = lprint - else - ludef_print = .false. - end if - - -!!!----------------------------------------------------------------------------- -!!! Sets the surface identification tolerance -!!!----------------------------------------------------------------------------- - if(present(layer_sep))then - tol = layer_sep - else - tol = 1.D0 !!!tolerance of 1 Å for defining a layer - end if - - abc=cshift(abc,3-axis) - c_along = abs(dot_product(lat(axis,:),& - uvec(cross(lat(abc(1),:),lat(abc(2),:))))) - tol = tol / c_along - !tol = tol/modu(lat(axis,1:3)) - lmirror=.false. - - -!!!----------------------------------------------------------------------------- -!!! Set up basis list that will order them wrt distance along 'axis' -!!!----------------------------------------------------------------------------- - allocate(bas_list(bas%natom,3)) - init = 1 - do is=1,bas%nspec - bas_list(init:init+bas%spec(is)%num-1,:3) = bas%spec(is)%atom(:,:3) - init = init + bas%spec(is)%num - end do - call sort_col(bas_list,col=axis) - - -!!!----------------------------------------------------------------------------- -!!! Find largest separation between atoms -!!!----------------------------------------------------------------------------- - max_sep = bas_list(1,axis) - (bas_list(bas%natom,axis)-1.D0) - height = ( bas_list(1,axis) + (bas_list(bas%natom,axis)-1.D0) )/2.D0 - do i=1,bas%natom-1 - dtmp1 = bas_list(i+1,axis) - bas_list(i,axis) - if(dtmp1.gt.max_sep)then - max_sep = dtmp1 - height = ( bas_list(i+1,axis) + bas_list(i,axis) )/2.D0 - end if - end do - if(max_sep.lt.tol)then - write(0,'("ERROR: Error in mod_sym.f90")') - write(0,'(2X,"get_terminations subroutine unable to find a separation & - &in the material that is greater than LAYER_SEP")') - write(0,'(2X,"Writing material to ''unlayerable.vasp''")') - open(13,file="unlayerable.vasp") - call geom_write(13,lat,bas) - close(13) - write(0,'(2X,"We suggest reducing LAYER_SEP to less than ",F6.4)') & - max_sep - write(0,'(2X,"Please inform the developers of this and give details & - &of what structure caused this")') - write(0,'("Stopping...")') - stop - end if - bas_list(:,axis) = bas_list(:,axis) - height - bas_list(:,axis) = bas_list(:,axis) - floor(bas_list(:,axis)) - call sort_col(bas_list,col=axis) - - -!!!----------------------------------------------------------------------------- -!!! Finds number of non-unique terminations -!!!----------------------------------------------------------------------------- - nterm=1 - allocate(term_arr(bas%natom)) - term_arr(:)%natom=0 - term_arr(:)%hmin=0 - term_arr(:)%hmax=0 - term_arr(1)%hmin=bas_list(1,axis) - term_arr(1)%hmax=bas_list(1,axis) - min_loc = 1 - itmp1 = 1 - term_loop1: do - - !! get the atom at that height. - !vtmp1 = get_min_dist(lat,bas,bas_list(itmp1,:3),.true.,axis,.true.,.false.) - !itmp1 = minloc(bas_list(:,axis) - vtmp1(axis), dim=1, & - ! mask = abs(bas_list(:,axis) - (bas_list(itmp1,axis) + vtmp1(axis))& - ! ).lt.tol_sym) - - itmp1 = minloc(bas_list(:,axis) - term_arr(nterm)%hmax, dim=1, & - mask = bas_list(:,axis) - term_arr(nterm)%hmax.gt.0.D0) - if(itmp1.gt.bas%natom.or.itmp1.le.0)then - term_arr(nterm)%natom = bas%natom - min_loc + 1 - exit term_loop1 - end if - - !dtmp1 = modu(matmul(vtmp1,lat)) - dtmp1 = bas_list(itmp1,axis) - term_arr(nterm)%hmax - if(dtmp1.le.tol)then - term_arr(nterm)%hmax = bas_list(itmp1,axis) - else - term_arr(nterm)%natom = itmp1 - min_loc - min_loc = itmp1 - nterm = nterm + 1 - term_arr(nterm)%hmin = bas_list(itmp1,axis) - term_arr(nterm)%hmax = bas_list(itmp1,axis) - end if - - end do term_loop1 - term_arr(:nterm)%hmin = term_arr(:nterm)%hmin + height - term_arr(:nterm)%hmax = term_arr(:nterm)%hmax + height - - -!!!----------------------------------------------------------------------------- -!!! Set up system symmetries -!!!----------------------------------------------------------------------------- - allocate(bas_arr(2*nterm)) - allocate(bas_arr_reject(2*nterm)) - dim = size(bas%spec(1)%atom(1,:)) - do i=1,2*nterm - allocate(bas_arr(i)%spec(bas%nspec)) - allocate(bas_arr_reject(i)%spec(bas%nspec)) - do is=1,bas%nspec - allocate(bas_arr(i)%spec(is)%atom(& - bas%spec(is)%num,dim)) - allocate(bas_arr_reject(i)%spec(is)%atom(& - bas%spec(is)%num,dim)) - end do - end do - - -!!!----------------------------------------------------------------------------- -!!! Print location of unique terminations -!!!----------------------------------------------------------------------------- - mterm = 0 - ireject = 0 - grp_store%lspace = .true. - grp_store%confine%l = .true. - grp_store%confine%laxis(axis) = .true. - call sym_setup(grp_store,lat,predefined=.false.,new_start=.true.) - - !!WRITE OUT THE STRUCTURES HERE AND COMPARE - !do i=1,grp_store%nsym - ! write(0,*) i - ! write(0,'(4(2X,F6.2))') grp_store%sym(i,:4,:3) - ! write(0,*) det(grp_store%sym(i,:3,:3)) - ! write(0,*) - !end do - - - !!-------------------------------------------------------------------------- - !! Handle inversion matrix (centre of inversion must be accounted for) - !!-------------------------------------------------------------------------- - !! change symmetry constraints after setting up symmetries - !! this is done to constrain the matching of two bases in certain directions - grp_store%confine%l = .false. - grp_store%confine%laxis(axis) = .false. - call check_sym(grp_store,bas1=bas,iperm=-1,lsave=.true.) - inv_mat = 0.D0 - do i=1,3 - inv_mat(i,i) = -1.D0 - end do - do i=1,grp_store%nsym - if(all(abs(grp_store%sym(i,:3,:3)-inv_mat).lt.tol_sym))then - itmp1 = i - exit - end if - end do - do i=1,grp_store%nsymop - if(all(abs(savsym(i,:3,:3)-inv_mat).lt.tol_sym)) & - grp_store%sym(itmp1,4,:3) = savsym(i,4,:3) - end do - !do i=1,grp_store%nsymop - ! write(0,*) i - ! write(0,'(4(2X,F9.4))') grp_store%sym(i,:4,:3) - ! write(0,*) det(grp_store%sym(i,:3,:3)) - ! write(0,*) - !end do - - - !!-------------------------------------------------------------------------- - !! Determine unique surface terminations - !!-------------------------------------------------------------------------- - grp_store%confine%l = .true. - grp_store%confine%laxis(axis) = .true. - allocate(term_arr_uniq(2*nterm)) - allocate(reject_match(nterm,2)) - shift_loop1:do i=1,nterm - mterm = mterm + 1 - - bas_arr(mterm) = bas - centre = term_arr(i)%hmin + (term_arr(i)%hmax - term_arr(i)%hmin)/2.D0 - call shifter(bas_arr(mterm),axis,1-centre,.true.) - !if(ludef_print) write(6,'(1X,I3,8X,F7.5,9X,F7.5,8X,I3)') & - ! i,term_arr(i)%hmin,term_arr(i)%hmax,term_arr(i)%natom - sym_if: if(i.ne.1)then - sym_loop1:do j=1,mterm-1 - if(abs(abs(term_arr(i)%hmax-term_arr(i)%hmin) - & - abs(term_arr_uniq(j)%hmax-term_arr_uniq(j)%hmin)).gt.tol_sym) & - cycle sym_loop1 - call clone_grp(grp_store,grp1) - call check_sym(grp1,bas1=bas_arr(mterm),& - iperm=-1,tmpbas2=bas_arr(j),lsave=.true.) - if(grp1%nsymop.ne.0)then - !write(0,*) "we have a possible reject" - !if(any(savsym(:grp1%nsymop,axis,axis).eq.-1.D0))then - if(abs(savsym(1,axis,axis)+1.D0).lt.tol_sym)then - ireject = ireject + 1 - reject_match(ireject,:) = [ i, j ] - bas_arr_reject(ireject) = bas_arr(mterm) - lmirror=.true. - else - term_arr_uniq(j)%nstep = term_arr_uniq(j)%nstep + 1 - term_arr_uniq(j)%ladder(term_arr_uniq(j)%nstep) = & - term_arr(i)%hmin - term_arr_uniq(j)%hmin - end if - mterm = mterm - 1 - cycle shift_loop1 - end if - end do sym_loop1 - end if sym_if - term_arr_uniq(mterm) = term_arr(i) - term_arr_uniq(mterm)%nstep = 1 - allocate(term_arr_uniq(mterm)%ladder(nterm)) - term_arr_uniq(mterm)%ladder(:) = 0.D0 - end do shift_loop1 - - - !!-------------------------------------------------------------------------- - !! Set up mirror/inversion symmetries of the matrix - !!-------------------------------------------------------------------------- - grp_store_inv%confine%axis=axis - grp_store_inv%confine%laxis=.false. - grp_store_inv%lspace = .true. - grp_store_inv%confine%l = .true. - grp_store_inv%confine%laxis(axis) = .true. - call sym_setup(grp_store_inv,lat,predefined=.false.,new_start=.true.) - itmp1 = count(abs(grp_store_inv%sym(:,3,3)+1.D0).lt.tol_sym) - allocate(tmpsym(itmp1,4,4)) - allocate(tmpop(itmp1)) - itmp1 = 0 - do i=1,grp_store_inv%nsym - if(abs(grp_store_inv%sym(i,3,3)+1.D0).lt.tol_sym)then - itmp1=itmp1+1 - tmpsym(itmp1,:,:) = grp_store_inv%sym(i,:,:) - tmpop(itmp1) = i - end if - end do - grp_store_inv%nsym = itmp1 - grp_store_inv%nlatsym = itmp1 - call move_alloc(tmpsym,grp_store_inv%sym) - allocate(grp_store_inv%op(itmp1)) - grp_store_inv%op(:) = tmpop(:itmp1) - s_end = grp_store_inv%nsym - - - !!-------------------------------------------------------------------------- - !! Check rejects for inverse surface termination of saved - !!-------------------------------------------------------------------------- - ident = 0.D0 - do i=1,3 - ident(i,i) = 1.D0 - end do - vec_compare = 0.D0 - vec_compare(axis) = -1.D0 - allocate(success(ireject)) - success=0 - reject_loop1: do i=1,ireject - lunique=.true. - itmp1=reject_match(i,1) - itmp2=reject_match(i,2) - !! Check if comparison termination has already been compared successfully - comparison_list = [ itmp2 ] - !! check against all previous reject-turned-unique terminations - prior_check: if(any(success(1:i-1:1).eq.itmp2))then - do j = 1, i-1, 1 - if(success(j).eq.itmp2)then - s_end = grp_store%nsym - call clone_grp(grp_store,grp1) - call check_sym(grp1,bas1=bas_arr_reject(j),& - iperm=-1,tmpbas2=bas_arr_reject(i),lsave=.true.) - if(grp1%nsymop.ne.0)then - if(abs(savsym(1,axis,axis)+1.D0).gt.tol_sym)then - lunique = .false. - itmp2 = reject_match(j,2) - exit prior_check - end if - end if - comparison_list = [ comparison_list, reject_match(j,2) ] - end if - end do - end if prior_check - - unique_condition1: if(lunique)then - s_end = grp_store_inv%nsym - lunique = .true. - do k = 1, size(comparison_list) - itmp2 = comparison_list(k) - call clone_grp(grp_store_inv,grp1) - call check_sym(grp1,bas_arr(itmp2),& - iperm=-1,lsave=.true.,lcheck_all=.true.) - - !! Check if inversions are present in comparison termination - ltmp1=.false. - do j = 1, grp1%nsymop, 1 - if(abs(det(savsym(j,:3,:3))+1.D0).le.tol_sym) ltmp1=.true. - end do - !! If they are not, then no point comparing. It is a new termination - if(.not.ltmp1) cycle - - call clone_grp(grp_store_inv,grp1) - call check_sym(grp1,bas_arr(itmp2),& - tmpbas2=bas_arr_reject(i), & - iperm=-1, & - lsave=.true., & - lcheck_all=.true. & - ) - - !! Check det of all symmetry operations. If any are 1, move on - !! This is because they are just rotations as can be captured ... - !! ... through lattice matches. - !! Solely inversions are unique and must be captured. - do j = 1, grp1%nsymop, 1 - if(abs(det(savsym(j,:3,:3))-1.D0).le.tol_sym) lunique=.false. - end do - if(savsym(1,4,axis).eq.& - 2.D0 * min( & - term_arr_uniq(itmp2)%hmin, & - 0.5D0-term_arr_uniq(itmp2)%hmin & - ) & - ) lunique=.false. - - if(.not.( & - all(abs(savsym(1,axis,:3) - vec_compare(:)).lt.tol_sym).and.& - all(abs(savsym(1,:3,axis) - vec_compare(:)).lt.tol_sym) & - ) ) lunique=.false. - - if(lunique) exit unique_condition1 - end do - end if unique_condition1 - - if(lunique)then - mterm = mterm + 1 - success(i) = itmp2 - bas_arr(mterm) = bas_arr_reject(i) - term_arr_uniq(mterm) = term_arr(itmp1) - reject_match(i,2) = mterm - term_arr_uniq(mterm)%nstep = 1 - allocate(term_arr_uniq(mterm)%ladder(ireject+1)) - term_arr_uniq(mterm)%ladder(1) = 0.D0 - else - term_arr_uniq(itmp2)%nstep = term_arr_uniq(itmp2)%nstep + 1 - term_arr_uniq(itmp2)%ladder(term_arr_uniq(itmp2)%nstep) = & - term_arr(itmp1)%hmin - term_arr_uniq(itmp2)%hmin - end if - end do reject_loop1 - - - !!-------------------------------------------------------------------------- - !! Populate termination output - !!-------------------------------------------------------------------------- - allocate(term%arr(mterm)) - term%tol=tol - term%axis=axis - term%nterm=mterm - term%lmirror = lmirror - if(ludef_print)& - write(6,& - '(1X,"Term.",3X,"Min layer loc",3X,& - &"Max layer loc",3X,"no. atoms")' & - ) - dtmp1 = term_arr_uniq(1)%hmin-1.D-6 - itmp1 = 1 - do i=1,mterm - allocate(term%arr(i)%ladder(term_arr_uniq(i)%nstep)) - term%arr(i)%hmin = term_arr_uniq(itmp1)%hmin - term%arr(i)%hmax = term_arr_uniq(itmp1)%hmax - term%arr(i)%natom = term_arr_uniq(itmp1)%natom - term%arr(i)%nstep = term_arr_uniq(itmp1)%nstep - term%arr(i)%ladder(:term%arr(i)%nstep) = & - term_arr_uniq(i)%ladder(:term%arr(i)%nstep) - if(ludef_print) write(6,'(1X,I3,8X,F7.5,9X,F7.5,8X,I3)') & - i,term%arr(i)%hmin,term%arr(i)%hmax,term%arr(i)%natom - itmp1 = minloc(term_arr_uniq(:)%hmin,& - mask=term_arr_uniq(:)%hmin.gt.dtmp1+tol,dim=1) - if(itmp1.eq.0) then - itmp1 = minloc(term_arr_uniq(:)%hmin,& - mask=term_arr_uniq(:)%hmin.gt.dtmp1+tol-1.D0,dim=1) - end if - dtmp1 = term_arr_uniq(itmp1)%hmin - end do - term%nstep = maxval(term%arr(:)%nstep) - - - !!-------------------------------------------------------------------------- - !! Check to ensure equivalent number of steps for each termination - !!-------------------------------------------------------------------------- - !! Not yet certain whether each termination should have samve number ... - !! ... of ladder rungs. That's why this check is here. - if(all(term%arr(:)%nstep.ne.term%nstep))then - write(0,'("ERROR: Number of rungs in terminations no equivalent for & - &every termination! Please report this to developers.\n& - &Exiting...")') - call exit() - end if - - - end function get_terminations -!!!############################################################################# - -end module mod_sym diff --git a/src/main.f90 b/src/main.f90 deleted file mode 100644 index 1712ae8..0000000 --- a/src/main.f90 +++ /dev/null @@ -1,101 +0,0 @@ -!!!############################################################################# -!!! ARTEMIS -!!! Code written by Ned Thaddeus Taylor and Francis Huw Davies -!!! Code part of the ARTEMIS group (Hepplestone research group). -!!! Think Hepplestone, think HRG. -!!!############################################################################# -program artemis - use inputs - use interface_subroutines - implicit none - - -!!!updated 2021/11/12 - - -!!!----------------------------------------------------------------------------- -!!! set up global variables -!!!----------------------------------------------------------------------------- - call set_global_vars() - - -!!!----------------------------------------------------------------------------- -!!! checks what task has been called and starts the appropriate codes -!!!----------------------------------------------------------------------------- -!!! SEARCH = Substitutions, Extension, Additions & Rotations for Creating Heterostructures -!!! ASPECT = Additions, Substitutions & Positional Editing of Crystals Tool -!!! ARTEMIS = Ab initio Restructuring Tool Enabling Modelling of Interface Structures -!!! ARTIE = Alloying & Rotating Tool for Intermixed structure Editing ??? - select case(task) - case(0) ! cell_edit/ASPECT - write(6,'(1X,"task ",I0," set",/,1X,"Performing Cell Edits")') task - if(lsurf_gen)then - write(0,'(1X,"Finding terminations for lower material.")') - call gen_terminations(struc1_lat,struc1_bas,lw_mplane,axis,& - thickness=lw_thickness) - write(0,'(1X,"Terminations printed.",/,1X,"Exiting...")') - stop - end if - call edit_structure(& - lat=struc1_lat,bas=struc1_bas,& - ofile=out_filename,edits=edits,& - lnorm=lnorm_lat) - - case(1) ! interfaces/ARTEMIS/SEARCH - write(6,'(1X,"task ",I0," set",/,1X,"Performing Interface Generation")') task - - !!------------------------------------------------------------------------- - !! surface generator - !!------------------------------------------------------------------------- - if(lsurf_gen)then - - call system('mkdir -p DTERMINATIONS') - call chdir("DTERMINATIONS") - - if(all(lw_mplane.eq.0))then - write(6,'("No Miller plane defined for lower material.")') - write(6,'("Skipping...")') - else - write(6,'(1X,"Finding terminations for lower material.")') - call gen_terminations(struc1_lat,struc1_bas,lw_mplane,axis,& - directory="DLW_TERMS",thickness=lw_thickness,udef_layer_sep=lw_layer_sep) - end if - if(all(up_mplane.eq.0))then - write(6,'("No Miller plane defined for upper material.")') - write(6,'("Skipping...")') - else - write(6,'(1X,"Finding terminations for upper material.")') - call gen_terminations(struc2_lat,struc2_bas,up_mplane,axis,& - directory="DUP_TERMS",thickness=up_thickness,udef_layer_sep=up_layer_sep) - end if - write(6,'(1X,"Terminations printed.",/,1X,"Exiting...")') - stop - end if - - - !!------------------------------------------------------------------------- - !! interface generator - !!------------------------------------------------------------------------- - if(irestart.eq.0)then - call gen_interfaces(tolerance,& - struc1_lat,struc2_lat,& - struc1_bas,struc2_bas) - else - call gen_interfaces_restart(struc1_lat,struc1_bas) - end if - - - case(2) ! defects/ARTIE - write(6,'(1X,"task ",I0," set",/,1X,"Performing Defect Generation")') task - - - case default - write(6,'(1X,"No task selected.")') - write(6,'(1X,"Exiting code...")') - call exit() - end select - - - -end program artemis - diff --git a/src/wrapper/f90wrap_artemis.f90 b/src/wrapper/f90wrap_artemis.f90 new file mode 100644 index 0000000..09046ee --- /dev/null +++ b/src/wrapper/f90wrap_artemis.f90 @@ -0,0 +1,4 @@ +! Module artemis defined in file ../fortran/artemis.f90 + +! End of module artemis defined in file ../fortran/artemis.f90 + diff --git a/src/wrapper/f90wrap_mod_generator.f90 b/src/wrapper/f90wrap_mod_generator.f90 new file mode 100644 index 0000000..dfa470a --- /dev/null +++ b/src/wrapper/f90wrap_mod_generator.f90 @@ -0,0 +1,1726 @@ +! Module artemis__generator defined in file ../fortran/lib/mod_intf_generator.f90 + +!############################################################################### +! Members of type artemis_generator_type +!############################################################################### +subroutine f90wrap_artemis_gen_type__get__num_structures(this, f90wrap_num_structures) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(out) :: f90wrap_num_structures + + this_ptr = transfer(this, this_ptr) + f90wrap_num_structures = this_ptr%p%num_structures +end subroutine f90wrap_artemis_gen_type__get__num_structures + +subroutine f90wrap_artemis_gen_type__set__num_structures(this, f90wrap_num_structures) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in) :: f90wrap_num_structures + + this_ptr = transfer(this, this_ptr) + this_ptr%p%num_structures = f90wrap_num_structures +end subroutine f90wrap_artemis_gen_type__set__num_structures + +subroutine f90wrap_artemis_gen_type__get__max_num_structures(this, f90wrap_max_num_structures) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(out) :: f90wrap_max_num_structures + + this_ptr = transfer(this, this_ptr) + f90wrap_max_num_structures = this_ptr%p%max_num_structures +end subroutine f90wrap_artemis_gen_type__get__max_num_structures + +subroutine f90wrap_artemis_gen_type__set__max_num_structures(this, f90wrap_max_num_structures) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in) :: f90wrap_max_num_structures + + this_ptr = transfer(this, this_ptr) + this_ptr%p%max_num_structures = f90wrap_max_num_structures +end subroutine f90wrap_artemis_gen_type__set__max_num_structures + + +subroutine f90wrap_artemis_gen_type__get__structure_lw(this, f90wrap_structure_lw) + use artemis__generator, only: artemis_generator_type + use artemis__geom_rw, only: basis_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(out) :: f90wrap_structure_lw(2) + type(basis_type_ptr_type) :: structure_lw_ptr + + this_ptr = transfer(this, this_ptr) + structure_lw_ptr%p => this_ptr%p%structure_lw + f90wrap_structure_lw = transfer(structure_lw_ptr,f90wrap_structure_lw) +end subroutine f90wrap_artemis_gen_type__get__structure_lw + +subroutine f90wrap_artemis_gen_type__set__structure_lw(this, f90wrap_structure_lw) + use artemis__generator, only: artemis_generator_type + use artemis__geom_rw, only: basis_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in) :: f90wrap_structure_lw(2) + type(basis_type_ptr_type) :: structure_lw_ptr + + this_ptr = transfer(this, this_ptr) + structure_lw_ptr = transfer(f90wrap_structure_lw,structure_lw_ptr) + this_ptr%p%structure_lw = structure_lw_ptr%p +end subroutine f90wrap_artemis_gen_type__set__structure_lw + +subroutine f90wrap_artemis_gen_type__get__structure_up(this, f90wrap_structure_up) + use artemis__generator, only: artemis_generator_type + use artemis__geom_rw, only: basis_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(out) :: f90wrap_structure_up(2) + type(basis_type_ptr_type) :: structure_up_ptr + + this_ptr = transfer(this, this_ptr) + structure_up_ptr%p => this_ptr%p%structure_up + f90wrap_structure_up = transfer(structure_up_ptr,f90wrap_structure_up) +end subroutine f90wrap_artemis_gen_type__get__structure_up + +subroutine f90wrap_artemis_gen_type__set__structure_up(this, f90wrap_structure_up) + use artemis__generator, only: artemis_generator_type + use artemis__geom_rw, only: basis_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in) :: f90wrap_structure_up(2) + type(basis_type_ptr_type) :: structure_up_ptr + + this_ptr = transfer(this, this_ptr) + structure_up_ptr = transfer(f90wrap_structure_up,structure_up_ptr) + this_ptr%p%structure_up = structure_up_ptr%p +end subroutine f90wrap_artemis_gen_type__set__structure_up + +subroutine f90wrap_artemis_gen_type__array__elastic_tensor_lw(this, nd, dtype, dshape, dloc) + use artemis__generator, only: artemis_generator_type + use, intrinsic :: iso_c_binding, only : c_int + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer(c_int), intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer(c_int), intent(out) :: nd + integer(c_int), intent(out) :: dtype + integer(c_int), dimension(10), intent(out) :: dshape + integer*8, intent(out) :: dloc + + nd = 1 + dtype = 11 + this_ptr = transfer(this, this_ptr) + if (allocated(this_ptr%p%elastic_tensor_lw)) then + dshape(1:2) = shape(this_ptr%p%elastic_tensor_lw) + dloc = loc(this_ptr%p%elastic_tensor_lw) + else + dloc = 0 + end if +end subroutine f90wrap_artemis_gen_type__array__elastic_tensor_lw + +subroutine f90wrap_artemis_gen_type__array__elastic_tensor_up(this, nd, dtype, dshape, dloc) + use artemis__generator, only: artemis_generator_type + use, intrinsic :: iso_c_binding, only : c_int + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer(c_int), intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer(c_int), intent(out) :: nd + integer(c_int), intent(out) :: dtype + integer(c_int), dimension(10), intent(out) :: dshape + integer*8, intent(out) :: dloc + + nd = 1 + dtype = 11 + this_ptr = transfer(this, this_ptr) + if (allocated(this_ptr%p%elastic_tensor_up)) then + dshape(1:2) = shape(this_ptr%p%elastic_tensor_up) + dloc = loc(this_ptr%p%elastic_tensor_up) + else + dloc = 0 + end if +end subroutine f90wrap_artemis_gen_type__array__elastic_tensor_up + +subroutine f90wrap_artemis_gen_type__get__use_pricel_lw(this, f90wrap_use_pricel_lw) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + logical, intent(out) :: f90wrap_use_pricel_lw + + this_ptr = transfer(this, this_ptr) + f90wrap_use_pricel_lw = this_ptr%p%use_pricel_lw +end subroutine f90wrap_artemis_gen_type__get__use_pricel_lw + +subroutine f90wrap_artemis_gen_type__set__use_pricel_lw(this, f90wrap_use_pricel_lw) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + logical, intent(in) :: f90wrap_use_pricel_lw + + this_ptr = transfer(this, this_ptr) + this_ptr%p%use_pricel_lw = f90wrap_use_pricel_lw +end subroutine f90wrap_artemis_gen_type__set__use_pricel_lw + +subroutine f90wrap_artemis_gen_type__get__use_pricel_up(this, f90wrap_use_pricel_up) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + logical, intent(out) :: f90wrap_use_pricel_up + + this_ptr = transfer(this, this_ptr) + f90wrap_use_pricel_up = this_ptr%p%use_pricel_up +end subroutine f90wrap_artemis_gen_type__get__use_pricel_up + +subroutine f90wrap_artemis_gen_type__set__use_pricel_up(this, f90wrap_use_pricel_up) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + logical, intent(in) :: f90wrap_use_pricel_up + + this_ptr = transfer(this, this_ptr) + this_ptr%p%use_pricel_up = f90wrap_use_pricel_up +end subroutine f90wrap_artemis_gen_type__set__use_pricel_up + +subroutine f90wrap_artemis_gen_type__array__miller_lw(this, nd, dtype, dshape, dloc) + use artemis__generator, only: artemis_generator_type + use, intrinsic :: iso_c_binding, only : c_int + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer(c_int), intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer(c_int), intent(out) :: nd + integer(c_int), intent(out) :: dtype + integer(c_int), dimension(10), intent(out) :: dshape + integer*8, intent(out) :: dloc + + nd = 1 + dtype = 5 + this_ptr = transfer(this, this_ptr) + dshape(1:1) = shape(this_ptr%p%miller_lw) + dloc = loc(this_ptr%p%miller_lw) +end subroutine f90wrap_artemis_gen_type__array__miller_lw + +subroutine f90wrap_artemis_gen_type__array__miller_up(this, nd, dtype, dshape, dloc) + use artemis__generator, only: artemis_generator_type + use, intrinsic :: iso_c_binding, only : c_int + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer(c_int), intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer(c_int), intent(out) :: nd + integer(c_int), intent(out) :: dtype + integer(c_int), dimension(10), intent(out) :: dshape + integer*8, intent(out) :: dloc + + nd = 1 + dtype = 5 + this_ptr = transfer(this, this_ptr) + dshape(1:1) = shape(this_ptr%p%miller_up) + dloc = loc(this_ptr%p%miller_up) +end subroutine f90wrap_artemis_gen_type__array__miller_up + +subroutine f90wrap_artemis_gen_type__get__is_layered_lw(this, f90wrap_is_layered_lw) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + logical, intent(out) :: f90wrap_is_layered_lw + + this_ptr = transfer(this, this_ptr) + f90wrap_is_layered_lw = this_ptr%p%is_layered_lw +end subroutine f90wrap_artemis_gen_type__get__is_layered_lw + +subroutine f90wrap_artemis_gen_type__set__is_layered_lw(this, f90wrap_is_layered_lw) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + logical, intent(in) :: f90wrap_is_layered_lw + + this_ptr = transfer(this, this_ptr) + this_ptr%p%is_layered_lw = f90wrap_is_layered_lw +end subroutine f90wrap_artemis_gen_type__set__is_layered_lw + +subroutine f90wrap_artemis_gen_type__get__is_layered_up(this, f90wrap_is_layered_up) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + logical, intent(out) :: f90wrap_is_layered_up + + this_ptr = transfer(this, this_ptr) + f90wrap_is_layered_up = this_ptr%p%is_layered_up +end subroutine f90wrap_artemis_gen_type__get__is_layered_up + +subroutine f90wrap_artemis_gen_type__set__is_layered_up(this, f90wrap_is_layered_up) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + logical, intent(in) :: f90wrap_is_layered_up + + this_ptr = transfer(this, this_ptr) + this_ptr%p%is_layered_up = f90wrap_is_layered_up +end subroutine f90wrap_artemis_gen_type__set__is_layered_up + +subroutine f90wrap_artemis_gen_type__get__ludef_is_lay4aa6(this, f90wrap_ludef_is_layered_lw) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + logical, intent(out) :: f90wrap_ludef_is_layered_lw + + this_ptr = transfer(this, this_ptr) + f90wrap_ludef_is_layered_lw = this_ptr%p%ludef_is_layered_lw +end subroutine f90wrap_artemis_gen_type__get__ludef_is_lay4aa6 + +subroutine f90wrap_artemis_gen_type__set__ludef_is_lay87a5(this, f90wrap_ludef_is_layered_lw) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + logical, intent(in) :: f90wrap_ludef_is_layered_lw + + this_ptr = transfer(this, this_ptr) + this_ptr%p%ludef_is_layered_lw = f90wrap_ludef_is_layered_lw +end subroutine f90wrap_artemis_gen_type__set__ludef_is_lay87a5 + +subroutine f90wrap_artemis_gen_type__get__ludef_is_lay60fd(this, f90wrap_ludef_is_layered_up) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + logical, intent(out) :: f90wrap_ludef_is_layered_up + + this_ptr = transfer(this, this_ptr) + f90wrap_ludef_is_layered_up = this_ptr%p%ludef_is_layered_up +end subroutine f90wrap_artemis_gen_type__get__ludef_is_lay60fd + +subroutine f90wrap_artemis_gen_type__set__ludef_is_laye6e4(this, f90wrap_ludef_is_layered_up) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + logical, intent(in) :: f90wrap_ludef_is_layered_up + + this_ptr = transfer(this, this_ptr) + this_ptr%p%ludef_is_layered_up = f90wrap_ludef_is_layered_up +end subroutine f90wrap_artemis_gen_type__set__ludef_is_laye6e4 + +subroutine f90wrap_artemis_gen_type__get__shift_method(this, f90wrap_shift_method) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(out) :: f90wrap_shift_method + + this_ptr = transfer(this, this_ptr) + f90wrap_shift_method = this_ptr%p%shift_method +end subroutine f90wrap_artemis_gen_type__get__shift_method + +subroutine f90wrap_artemis_gen_type__set__shift_method(this, f90wrap_shift_method) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in) :: f90wrap_shift_method + + this_ptr = transfer(this, this_ptr) + this_ptr%p%shift_method = f90wrap_shift_method +end subroutine f90wrap_artemis_gen_type__set__shift_method + +subroutine f90wrap_artemis_gen_type__get__num_shifts(this, f90wrap_num_shifts) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(out) :: f90wrap_num_shifts + + this_ptr = transfer(this, this_ptr) + f90wrap_num_shifts = this_ptr%p%num_shifts +end subroutine f90wrap_artemis_gen_type__get__num_shifts + +subroutine f90wrap_artemis_gen_type__set__num_shifts(this, f90wrap_num_shifts) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in) :: f90wrap_num_shifts + + this_ptr = transfer(this, this_ptr) + this_ptr%p%num_shifts = f90wrap_num_shifts +end subroutine f90wrap_artemis_gen_type__set__num_shifts + +subroutine f90wrap_artemis_gen_type__array__shifts(this, nd, dtype, dshape, dloc) + use artemis__generator, only: artemis_generator_type + use, intrinsic :: iso_c_binding, only : c_int + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer(c_int), intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer(c_int), intent(out) :: nd + integer(c_int), intent(out) :: dtype + integer(c_int), dimension(10), intent(out) :: dshape + integer*8, intent(out) :: dloc + + nd = 2 + dtype = 11 + this_ptr = transfer(this, this_ptr) + if (allocated(this_ptr%p%shifts)) then + dshape(1:2) = shape(this_ptr%p%shifts) + dloc = loc(this_ptr%p%shifts) + else + dloc = 0 + end if +end subroutine f90wrap_artemis_gen_type__array__shifts + +subroutine f90wrap_artemis_gen_type__get__interface_depth(this, f90wrap_interface_depth) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + real(4), intent(out) :: f90wrap_interface_depth + + this_ptr = transfer(this, this_ptr) + f90wrap_interface_depth = this_ptr%p%interface_depth +end subroutine f90wrap_artemis_gen_type__get__interface_depth + +subroutine f90wrap_artemis_gen_type__set__interface_depth(this, f90wrap_interface_depth) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + real(4), intent(in) :: f90wrap_interface_depth + + this_ptr = transfer(this, this_ptr) + this_ptr%p%interface_depth = f90wrap_interface_depth +end subroutine f90wrap_artemis_gen_type__set__interface_depth + +subroutine f90wrap_artemis_gen_type__get__separation_scale(this, f90wrap_separation_scale) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + real(4), intent(out) :: f90wrap_separation_scale + + this_ptr = transfer(this, this_ptr) + f90wrap_separation_scale = this_ptr%p%separation_scale +end subroutine f90wrap_artemis_gen_type__get__separation_scale + +subroutine f90wrap_artemis_gen_type__set__separation_scale(this, f90wrap_separation_scale) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + real(4), intent(in) :: f90wrap_separation_scale + + this_ptr = transfer(this, this_ptr) + this_ptr%p%separation_scale = f90wrap_separation_scale +end subroutine f90wrap_artemis_gen_type__set__separation_scale + +subroutine f90wrap_artemis_gen_type__get__depth_method(this, f90wrap_depth_method) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(out) :: f90wrap_depth_method + + this_ptr = transfer(this, this_ptr) + f90wrap_depth_method = this_ptr%p%depth_method +end subroutine f90wrap_artemis_gen_type__get__depth_method + +subroutine f90wrap_artemis_gen_type__set__depth_method(this, f90wrap_depth_method) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in) :: f90wrap_depth_method + + this_ptr = transfer(this, this_ptr) + this_ptr%p%depth_method = f90wrap_depth_method +end subroutine f90wrap_artemis_gen_type__set__depth_method + +subroutine f90wrap_artemis_gen_type__array_getitem__structure_data(f90wrap_this, f90wrap_i, structure_dataitem) + use artemis__generator, only: artemis_generator_type + use artemis__misc_types, only: struc_data_type + implicit none + + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + type struc_data_type_ptr_type + type(struc_data_type), pointer :: p => NULL() + end type struc_data_type_ptr_type + integer, intent(in) :: f90wrap_this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in) :: f90wrap_i + integer, intent(out) :: structure_dataitem(2) + type(struc_data_type_ptr_type) :: structure_data_ptr + + this_ptr = transfer(f90wrap_this, this_ptr) + if (allocated(this_ptr%p%structure_data)) then + if (f90wrap_i < 1 .or. f90wrap_i > size(this_ptr%p%structure_data)) then + call f90wrap_abort("array index out of range") + else + structure_data_ptr%p => this_ptr%p%structure_data(f90wrap_i) + structure_dataitem = transfer(structure_data_ptr,structure_dataitem) + endif + else + call f90wrap_abort("derived type array not allocated") + end if +end subroutine f90wrap_artemis_gen_type__array_getitem__structure_data + +subroutine f90wrap_artemis_gen_type__array_setitem__structure_data(f90wrap_this, f90wrap_i, structure_dataitem) + use artemis__generator, only: artemis_generator_type + use artemis__misc_types, only: struc_data_type + implicit none + + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + type struc_data_type_ptr_type + type(struc_data_type), pointer :: p => NULL() + end type struc_data_type_ptr_type + integer, intent(in) :: f90wrap_this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in) :: f90wrap_i + integer, intent(in) :: structure_dataitem(2) + type(struc_data_type_ptr_type) :: structure_data_ptr + + this_ptr = transfer(f90wrap_this, this_ptr) + if (allocated(this_ptr%p%structure_data)) then + if (f90wrap_i < 1 .or. f90wrap_i > size(this_ptr%p%structure_data)) then + call f90wrap_abort("array index out of range") + else + structure_data_ptr = transfer(structure_dataitem,structure_data_ptr) + this_ptr%p%structure_data(f90wrap_i) = structure_data_ptr%p + endif + else + call f90wrap_abort("derived type array not allocated") + end if +end subroutine f90wrap_artemis_gen_type__array_setitem__structure_data + +subroutine f90wrap_artemis_gen_type__array_len__structure_data(f90wrap_this, f90wrap_n) + use artemis__generator, only: artemis_generator_type + use artemis__misc_types, only: struc_data_type + implicit none + + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + type struc_data_type_ptr_type + type(struc_data_type), pointer :: p => NULL() + end type struc_data_type_ptr_type + integer, intent(out) :: f90wrap_n + integer, intent(in) :: f90wrap_this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + + this_ptr = transfer(f90wrap_this, this_ptr) + if (allocated(this_ptr%p%structure_data)) then + f90wrap_n = size(this_ptr%p%structure_data) + else + f90wrap_n = 0 + end if +end subroutine f90wrap_artemis_gen_type__array_len__structure_data + +subroutine f90wrap_artemis_gen_type__get__swap_method(this, f90wrap_swap_method) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(out) :: f90wrap_swap_method + + this_ptr = transfer(this, this_ptr) + f90wrap_swap_method = this_ptr%p%swap_method +end subroutine f90wrap_artemis_gen_type__get__swap_method + +subroutine f90wrap_artemis_gen_type__set__swap_method(this, f90wrap_swap_method) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in) :: f90wrap_swap_method + + this_ptr = transfer(this, this_ptr) + this_ptr%p%swap_method = f90wrap_swap_method +end subroutine f90wrap_artemis_gen_type__set__swap_method + +subroutine f90wrap_artemis_gen_type__get__num_swaps(this, f90wrap_num_swaps) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(out) :: f90wrap_num_swaps + + this_ptr = transfer(this, this_ptr) + f90wrap_num_swaps = this_ptr%p%num_swaps +end subroutine f90wrap_artemis_gen_type__get__num_swaps + +subroutine f90wrap_artemis_gen_type__set__num_swaps(this, f90wrap_num_swaps) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in) :: f90wrap_num_swaps + + this_ptr = transfer(this, this_ptr) + this_ptr%p%num_swaps = f90wrap_num_swaps +end subroutine f90wrap_artemis_gen_type__set__num_swaps + +subroutine f90wrap_artemis_gen_type__get__swap_density(this, f90wrap_swap_density) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + real(4), intent(out) :: f90wrap_swap_density + + this_ptr = transfer(this, this_ptr) + f90wrap_swap_density = this_ptr%p%swap_density +end subroutine f90wrap_artemis_gen_type__get__swap_density + +subroutine f90wrap_artemis_gen_type__set__swap_density(this, f90wrap_swap_density) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + real(4), intent(in) :: f90wrap_swap_density + + this_ptr = transfer(this, this_ptr) + this_ptr%p%swap_density = f90wrap_swap_density +end subroutine f90wrap_artemis_gen_type__set__swap_density + +subroutine f90wrap_artemis_gen_type__get__swap_depth(this, f90wrap_swap_depth) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + real(4), intent(out) :: f90wrap_swap_depth + + this_ptr = transfer(this, this_ptr) + f90wrap_swap_depth = this_ptr%p%swap_depth +end subroutine f90wrap_artemis_gen_type__get__swap_depth + +subroutine f90wrap_artemis_gen_type__set__swap_depth(this, f90wrap_swap_depth) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + real(4), intent(in) :: f90wrap_swap_depth + + this_ptr = transfer(this, this_ptr) + this_ptr%p%swap_depth = f90wrap_swap_depth +end subroutine f90wrap_artemis_gen_type__set__swap_depth + +subroutine f90wrap_artemis_gen_type__get__swap_sigma(this, f90wrap_swap_sigma) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + real(4), intent(out) :: f90wrap_swap_sigma + + this_ptr = transfer(this, this_ptr) + f90wrap_swap_sigma = this_ptr%p%swap_sigma +end subroutine f90wrap_artemis_gen_type__get__swap_sigma + +subroutine f90wrap_artemis_gen_type__set__swap_sigma(this, f90wrap_swap_sigma) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + real(4), intent(in) :: f90wrap_swap_sigma + + this_ptr = transfer(this, this_ptr) + this_ptr%p%swap_sigma = f90wrap_swap_sigma +end subroutine f90wrap_artemis_gen_type__set__swap_sigma + +subroutine f90wrap_artemis_gen_type__get__require_mirror_swaps( & + this, f90wrap_require_mirror_swaps) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + logical, intent(out) :: f90wrap_require_mirror_swaps + + this_ptr = transfer(this, this_ptr) + f90wrap_require_mirror_swaps = this_ptr%p%require_mirror_swaps +end subroutine f90wrap_artemis_gen_type__get__require_mirror_swaps + +subroutine f90wrap_artemis_gen_type__set__require_mirror_swaps( & + this, f90wrap_require_mirror_swaps) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + logical, intent(in) :: f90wrap_require_mirror_swaps + + this_ptr = transfer(this, this_ptr) + this_ptr%p%require_mirror_swaps = f90wrap_require_mirror_swaps +end subroutine f90wrap_artemis_gen_type__set__require_mirror_swaps + +subroutine f90wrap_artemis_gen_type__get__match_method(this, f90wrap_match_method) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(out) :: f90wrap_match_method + + this_ptr = transfer(this, this_ptr) + f90wrap_match_method = this_ptr%p%match_method +end subroutine f90wrap_artemis_gen_type__get__match_method + +subroutine f90wrap_artemis_gen_type__set__match_method(this, f90wrap_match_method) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in) :: f90wrap_match_method + + this_ptr = transfer(this, this_ptr) + this_ptr%p%match_method = f90wrap_match_method +end subroutine f90wrap_artemis_gen_type__set__match_method + +subroutine f90wrap_artemis_gen_type__get__max_num_matches(this, f90wrap_max_num_matches) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(out) :: f90wrap_max_num_matches + + this_ptr = transfer(this, this_ptr) + f90wrap_max_num_matches = this_ptr%p%max_num_matches +end subroutine f90wrap_artemis_gen_type__get__max_num_matches + +subroutine f90wrap_artemis_gen_type__set__max_num_matches(this, f90wrap_max_num_matches) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in) :: f90wrap_max_num_matches + + this_ptr = transfer(this, this_ptr) + this_ptr%p%max_num_matches = f90wrap_max_num_matches +end subroutine f90wrap_artemis_gen_type__set__max_num_matches + +subroutine f90wrap_artemis_gen_type__get__max_num_terms(this, f90wrap_max_num_terms) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(out) :: f90wrap_max_num_terms + + this_ptr = transfer(this, this_ptr) + f90wrap_max_num_terms = this_ptr%p%max_num_terms +end subroutine f90wrap_artemis_gen_type__get__max_num_terms + +subroutine f90wrap_artemis_gen_type__set__max_num_terms(this, f90wrap_max_num_terms) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in) :: f90wrap_max_num_terms + + this_ptr = transfer(this, this_ptr) + this_ptr%p%max_num_terms = f90wrap_max_num_terms +end subroutine f90wrap_artemis_gen_type__set__max_num_terms + +subroutine f90wrap_artemis_gen_type__get__max_num_planes(this, f90wrap_max_num_planes) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(out) :: f90wrap_max_num_planes + + this_ptr = transfer(this, this_ptr) + f90wrap_max_num_planes = this_ptr%p%max_num_planes +end subroutine f90wrap_artemis_gen_type__get__max_num_planes + +subroutine f90wrap_artemis_gen_type__set__max_num_planes(this, f90wrap_max_num_planes) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in) :: f90wrap_max_num_planes + + this_ptr = transfer(this, this_ptr) + this_ptr%p%max_num_planes = f90wrap_max_num_planes +end subroutine f90wrap_artemis_gen_type__set__max_num_planes + +subroutine f90wrap_artemis_gen_type__get__compensate_normal(this, f90wrap_compensate_normal) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + logical, intent(out) :: f90wrap_compensate_normal + + this_ptr = transfer(this, this_ptr) + f90wrap_compensate_normal = this_ptr%p%compensate_normal +end subroutine f90wrap_artemis_gen_type__get__compensate_normal + +subroutine f90wrap_artemis_gen_type__set__compensate_normal(this, f90wrap_compensate_normal) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + logical, intent(in) :: f90wrap_compensate_normal + + this_ptr = transfer(this, this_ptr) + this_ptr%p%compensate_normal = f90wrap_compensate_normal +end subroutine f90wrap_artemis_gen_type__set__compensate_normal + +subroutine f90wrap_artemis_gen_type__get__bondlength_cutoff(this, f90wrap_bondlength_cutoff) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + real(4), intent(out) :: f90wrap_bondlength_cutoff + + this_ptr = transfer(this, this_ptr) + f90wrap_bondlength_cutoff = this_ptr%p%bondlength_cutoff +end subroutine f90wrap_artemis_gen_type__get__bondlength_cutoff + +subroutine f90wrap_artemis_gen_type__set__bondlength_cutoff(this, f90wrap_bondlength_cutoff) + use artemis__generator, only: artemis_generator_type + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + real(4), intent(in) :: f90wrap_bondlength_cutoff + + this_ptr = transfer(this, this_ptr) + this_ptr%p%bondlength_cutoff = f90wrap_bondlength_cutoff +end subroutine f90wrap_artemis_gen_type__set__bondlength_cutoff + +subroutine f90wrap_artemis_gen_type__array__layer_separation_cutoff(this, nd, dtype, dshape, dloc) + use artemis__generator, only: artemis_generator_type + use, intrinsic :: iso_c_binding, only : c_int + implicit none + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer(c_int), intent(in) :: this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer(c_int), intent(out) :: nd + integer(c_int), intent(out) :: dtype + integer(c_int), dimension(10), intent(out) :: dshape + integer*8, intent(out) :: dloc + + nd = 1 + dtype = 11 + this_ptr = transfer(this, this_ptr) + dshape(1:1) = shape(this_ptr%p%layer_separation_cutoff) + dloc = loc(this_ptr%p%layer_separation_cutoff) +end subroutine f90wrap_artemis_gen_type__array__layer_separation_cutoff +!############################################################################### + + +!############################################################################### +! Interface for the generator type +!############################################################################### +subroutine f90wrap_intf_gen__artemis_gen_type_initialise(this) + use artemis__generator, only: artemis_generator_type + implicit none + + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(out), dimension(2) :: this + allocate(this_ptr%p) + this = transfer(this_ptr, this) +end subroutine f90wrap_intf_gen__artemis_gen_type_initialise + +subroutine f90wrap_intf_gen__artemis_gen_type_finalise(this) + use artemis__generator, only: artemis_generator_type + implicit none + + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + this_ptr = transfer(this, this_ptr) + deallocate(this_ptr%p) +end subroutine f90wrap_intf_gen__artemis_gen_type_finalise +!############################################################################### + + +!############################################################################### +! Structure data accessors +!############################################################################### +subroutine f90wrap_intf_gen__get_all_structures_data__binding_agt(ret_output, this) + use artemis__generator, only: artemis_generator_type + use artemis__misc_types, only: struc_data_type + implicit none + + type struc_data_type_xnum_array + type(struc_data_type), dimension(:), allocatable :: items + end type struc_data_type_xnum_array + + type struc_data_type_xnum_array_ptr_type + type(struc_data_type_xnum_array), pointer :: p => NULL() + end type struc_data_type_xnum_array_ptr_type + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + type(struc_data_type_xnum_array_ptr_type) :: ret_output_ptr + integer, intent(out), dimension(2) :: ret_output + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + this_ptr = transfer(this, this_ptr) + allocate(ret_output_ptr%p) + ret_output_ptr%p%items = this_ptr%p%get_all_structures_data() + ret_output = transfer(ret_output_ptr, ret_output) +end subroutine f90wrap_intf_gen__get_all_structures_data__binding_agt + +subroutine f90wrap_intf_gen__get_structure_data__binding_agt(this, ret_output, idx) + use artemis__generator, only: artemis_generator_type + use artemis__misc_types, only: struc_data_type + implicit none + + type struc_data_type_ptr_type + type(struc_data_type), pointer :: p => NULL() + end type struc_data_type_ptr_type + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + type(struc_data_type_ptr_type) :: ret_output_ptr + integer, intent(out), dimension(2) :: ret_output + integer, intent(in) :: idx + this_ptr = transfer(this, this_ptr) + allocate(ret_output_ptr%p) + ret_output_ptr%p = this_ptr%p%get_structure_data(idx=idx+1) + ret_output = transfer(ret_output_ptr, ret_output) +end subroutine f90wrap_intf_gen__get_structure_data__binding_agt + +subroutine f90wrap_intf_gen__get_all_structures_mismatch__binding_agt(ret_output, this, n0) + use artemis__generator, only: artemis_generator_type + implicit none + + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + real(4), intent(out), dimension(3,n0) :: ret_output + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + integer :: n0 + this_ptr = transfer(this, this_ptr) + ret_output = this_ptr%p%get_all_structures_mismatch() +end subroutine f90wrap_intf_gen__get_all_structures_mismatch__binding_agt + +subroutine f90wrap_intf_gen__get_structure_mismatch__binding_agt(this, ret_output, idx) + use artemis__generator, only: artemis_generator_type + implicit none + + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + real(4), dimension(3), intent(out) :: ret_output + integer, intent(in) :: idx + this_ptr = transfer(this, this_ptr) + ret_output = this_ptr%p%get_structure_mismatch(idx=idx) +end subroutine f90wrap_intf_gen__get_structure_mismatch__binding_agt + +subroutine f90wrap_intf_gen__get_all_structures_transform__binding_agt(ret_output, this, n0) + use artemis__generator, only: artemis_generator_type + implicit none + + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(out), dimension(3,3,2,n0) :: ret_output + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + integer :: n0 + this_ptr = transfer(this, this_ptr) + ret_output = this_ptr%p%get_all_structures_transform() +end subroutine f90wrap_intf_gen__get_all_structures_transform__binding_agt + +subroutine f90wrap_intf_gen__get_structure_transform__binding_agt(this, ret_output, idx) + use artemis__generator, only: artemis_generator_type + implicit none + + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + integer, dimension(3,3,2), intent(out) :: ret_output + integer, intent(in) :: idx + this_ptr = transfer(this, this_ptr) + ret_output = this_ptr%p%get_structure_transform(idx=idx) +end subroutine f90wrap_intf_gen__get_structure_transform__binding_agt + +subroutine f90wrap_intf_gen__get_all_structures_shift__binding_agt(ret_output, this, n0) + use artemis__generator, only: artemis_generator_type + implicit none + + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + real(4), intent(out), dimension(3,n0) :: ret_output + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + integer :: n0 + this_ptr = transfer(this, this_ptr) + ret_output = this_ptr%p%get_all_structures_shift() +end subroutine f90wrap_intf_gen__get_all_structures_shift__binding_agt + +subroutine f90wrap_intf_gen__get_structure_shift__binding_agt(this, ret_output, idx) + use artemis__generator, only: artemis_generator_type + implicit none + + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + real(4), dimension(3), intent(out) :: ret_output + integer, intent(in) :: idx + this_ptr = transfer(this, this_ptr) + ret_output = this_ptr%p%get_structure_shift(idx=idx) +end subroutine f90wrap_intf_gen__get_structure_shift__binding_agt +!############################################################################### + + +!############################################################################### +! Generation methods and tolerance handlers +!############################################################################### +subroutine f90wrap_intf_gen__set_tolerance__binding_agt(this, vector_mismatch, angle_mismatch, & + area_mismatch, max_length, max_area, max_fit, max_extension, angle_weight, area_weight) + use artemis__generator, only: artemis_generator_type + implicit none + + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + real(4), intent(in), optional :: vector_mismatch + real(4), intent(in), optional :: angle_mismatch + real(4), intent(in), optional :: area_mismatch + real(4), intent(in), optional :: max_length + real(4), intent(in), optional :: max_area + integer, intent(in), optional :: max_fit + integer, intent(in), optional :: max_extension + real(4), intent(in), optional :: angle_weight + real(4), intent(in), optional :: area_weight + this_ptr = transfer(this, this_ptr) + call this_ptr%p%set_tolerance( & + vector_mismatch=vector_mismatch, & + angle_mismatch=angle_mismatch, & + area_mismatch=area_mismatch, max_length=max_length, & + max_area=max_area, max_fit=max_fit, max_extension=max_extension, & + angle_weight=angle_weight, area_weight=area_weight) +end subroutine f90wrap_intf_gen__set_tolerance__binding_agt + +subroutine f90wrap_intf_gen__set_shift_method__binding__agt(this, method, num_shifts, shifts, & + interface_depth, separation_scale, depth_method, bondlength_cutoff, n0, n1) + use artemis__generator, only: artemis_generator_type + implicit none + + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + integer, intent(in), optional :: method + integer, intent(in), optional :: num_shifts + real(4), dimension(n0,n1), intent(in), optional :: shifts + real(4), intent(in), optional :: interface_depth + real(4), intent(in), optional :: separation_scale + integer, intent(in), optional :: depth_method + real(4), intent(in), optional :: bondlength_cutoff + integer :: n0 + !f2py intent(hide), depend(shifts) :: n0 = shape(shifts,0) + integer :: n1 + !f2py intent(hide), depend(shifts) :: n1 = shape(shifts,1) + this_ptr = transfer(this, this_ptr) + call this_ptr%p%set_shift_method(method=method, num_shifts=num_shifts, shifts=shifts, interface_depth=interface_depth, & + separation_scale=separation_scale, depth_method=depth_method, bondlength_cutoff=bondlength_cutoff) +end subroutine f90wrap_intf_gen__set_shift_method__binding__agt + +subroutine f90wrap_intf_gen__set_swap_method__binding__agt(this, method, num_swaps, swap_density, & + swap_depth, swap_sigma, require_mirror_swaps) + use artemis__generator, only: artemis_generator_type + implicit none + + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + integer, intent(in), optional :: method + integer, intent(in), optional :: num_swaps + real(4), intent(in), optional :: swap_density + real(4), intent(in), optional :: swap_depth + real(4), intent(in), optional :: swap_sigma + logical, intent(in), optional :: require_mirror_swaps + this_ptr = transfer(this, this_ptr) + call this_ptr%p%set_swap_method(method=method, num_swaps=num_swaps, swap_density=swap_density, swap_depth=swap_depth, & + swap_sigma=swap_sigma, require_mirror_swaps=require_mirror_swaps) +end subroutine f90wrap_intf_gen__set_swap_method__binding__agt + +subroutine f90wrap_intf_gen__set_match_method__binding__agt(this, method, max_num_matches, max_num_terms, & + max_num_planes, compensate_normal) + use artemis__generator, only: artemis_generator_type + implicit none + + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + integer, intent(in), optional :: method + integer, intent(in), optional :: max_num_matches + integer, intent(in), optional :: max_num_terms + integer, intent(in), optional :: max_num_planes + logical, intent(in), optional :: compensate_normal + this_ptr = transfer(this, this_ptr) + call this_ptr%p%set_match_method(method=method, max_num_matches=max_num_matches, max_num_terms=max_num_terms, & + max_num_planes=max_num_planes, compensate_normal=compensate_normal) +end subroutine f90wrap_intf_gen__set_match_method__binding__agt +!############################################################################### + + +!############################################################################### +! Material and surface property procedures +!############################################################################### +subroutine f90wrap_intf_gen__set_materials__binding__agt(this, structure_lw, structure_up, & + elastic_lw, elastic_up, use_pricel_lw, use_pricel_up, n0, n1, n2, n3) + use artemis__generator, only: artemis_generator_type + use artemis__geom_rw, only: basis_type + implicit none + + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + type(basis_type_ptr_type) :: structure_lw_ptr + integer, intent(in), optional, dimension(2) :: structure_lw + type(basis_type_ptr_type) :: structure_up_ptr + integer, intent(in), optional, dimension(2) :: structure_up + real(4), intent(in), optional, dimension(n0,n1) :: elastic_lw + real(4), intent(in), optional, dimension(n2,n3) :: elastic_up + logical, intent(in), optional :: use_pricel_lw + logical, intent(in), optional :: use_pricel_up + integer :: n0 + !f2py intent(hide), depend(elastic_lw) :: n0 = shape(elastic_lw,0) + integer :: n1 + !f2py intent(hide), depend(elastic_lw) :: n1 = shape(elastic_lw,1) + integer :: n2 + !f2py intent(hide), depend(elastic_up) :: n2 = shape(elastic_up,0) + integer :: n3 + !f2py intent(hide), depend(elastic_up) :: n3 = shape(elastic_up,1) + this_ptr = transfer(this, this_ptr) + if(present(structure_lw)) & + structure_lw_ptr = transfer(structure_lw, structure_lw_ptr) + if(present(structure_up)) & + structure_up_ptr = transfer(structure_up, structure_up_ptr) + call this_ptr%p%set_materials(structure_lw=structure_lw_ptr%p, structure_up=structure_up_ptr%p, & + elastic_lw=elastic_lw, elastic_up=elastic_up, use_pricel_lw=use_pricel_lw, & + use_pricel_up=use_pricel_up) +end subroutine f90wrap_intf_gen__set_materials__binding__agt + +subroutine f90wrap_intf_gen__set_surface_properties__binding__agt( & + this, & + miller_lw, miller_up, & + is_layered_lw, is_layered_up, & + require_stoichiometry_lw, require_stoichiometry_up, & + layer_separation_cutoff_lw, layer_separation_cutoff_up, layer_separation_cutoff, & + vacuum_gap, n0) + use artemis__generator, only: artemis_generator_type + implicit none + + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + integer, dimension(3), intent(in), optional :: miller_lw + integer, dimension(3), intent(in), optional :: miller_up + logical, intent(in), optional :: is_layered_lw + logical, intent(in), optional :: is_layered_up + logical, intent(in), optional :: require_stoichiometry_lw + logical, intent(in), optional :: require_stoichiometry_up + real(4), intent(in), optional :: layer_separation_cutoff_lw + real(4), intent(in), optional :: layer_separation_cutoff_up + real(4), dimension(n0), intent(in), optional :: layer_separation_cutoff + real(4), intent(in), optional :: vacuum_gap + integer :: n0 + !f2py intent(hide), depend(layer_separation_cutoff) :: n0 = shape(layer_separation_cutoff,0) + this_ptr = transfer(this, this_ptr) + call this_ptr%p%set_surface_properties( & + miller_lw=miller_lw, miller_up=miller_up, & + is_layered_lw=is_layered_lw, is_layered_up=is_layered_up, & + require_stoichiometry_lw=require_stoichiometry_lw, & + require_stoichiometry_up=require_stoichiometry_up, & + layer_separation_cutoff_lw=layer_separation_cutoff_lw, & + layer_separation_cutoff_up=layer_separation_cutoff_up, & + layer_separation_cutoff=layer_separation_cutoff, & + vacuum_gap=vacuum_gap) +end subroutine f90wrap_intf_gen__set_surface_properties__binding__agt + +subroutine f90wrap_intf_gen__reset_is_layered_lw__binding__agt(this) + use artemis__generator, only: artemis_generator_type + implicit none + + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + this_ptr = transfer(this, this_ptr) + call this_ptr%p%reset_is_layered_lw() +end subroutine f90wrap_intf_gen__reset_is_layered_lw__binding__agt + +subroutine f90wrap_intf_gen__reset_is_layered_up__binding__agt(this) + use artemis__generator, only: artemis_generator_type + implicit none + + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + this_ptr = transfer(this, this_ptr) + call this_ptr%p%reset_is_layered_up() +end subroutine f90wrap_intf_gen__reset_is_layered_up__binding__agt +!############################################################################### + + +!############################################################################### +! Structural feature identifiers +!############################################################################### +subroutine f90wrap_intf_gen__get_terminations__binding__agt( & + this, identifier, miller, surface, num_layers, thickness, & + orthogonalise, normalise, break_on_fail, & + verbose, exit_code, & + n_ret_structures, n0) + use artemis__geom_rw, only: basis_type + use artemis__generator, only: artemis_generator_type + use artemis__structure_cache, only: store_last_generated_structures + implicit none + + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + + type basis_type_xnum_array + type(basis_type), dimension(:), allocatable :: items + end type basis_type_xnum_array + + type basis_type_xnum_array_ptr_type + type(basis_type_xnum_array), pointer :: p => NULL() + end type basis_type_xnum_array_ptr_type + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + integer, intent(in):: identifier + integer, dimension(3), intent(in), optional :: miller + integer, intent(in), optional, dimension(n0) :: surface + real(4), intent(in), optional :: thickness + integer, intent(in), optional :: num_layers + logical, intent(in), optional :: orthogonalise + logical, intent(in), optional :: normalise + logical, intent(in), optional :: break_on_fail + integer, intent(in), optional :: verbose + integer, optional, intent(out) :: exit_code + integer :: n0 + !f2py intent(hide), depend(surface_lw) :: n0 = shape(surface_lw,0) + type(basis_type), allocatable, dimension(:) :: local_structures + integer, intent(out) :: n_ret_structures + + this_ptr = transfer(this, this_ptr) + local_structures = this_ptr%p%get_terminations( & + identifier=identifier, miller=miller, surface=surface, & + num_layers=num_layers, thickness=thickness, & + orthogonalise=orthogonalise, normalise=normalise, & + break_on_fail=break_on_fail, verbose=verbose, exit_code=exit_code) + + n_ret_structures = size(local_structures, dim=1) + + ! Store local_structures in a module-level array so Python can retrieve it + call store_last_generated_structures(local_structures) +end subroutine f90wrap_intf_gen__get_terminations__binding__agt + +subroutine f90wrap_intf_gen__get_interface_location__binding__agt( & + this, structure, axis, return_fractional, & + ret_location, ret_axis) + use artemis__geom_rw, only: basis_type + use artemis__generator, only: artemis_generator_type + use artemis__interface_identifier, only: intf_info_type + implicit none + + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + type(basis_type_ptr_type) :: structure_ptr + integer, intent(in), optional, dimension(2) :: structure + integer, intent(in), optional :: axis + logical, intent(in), optional :: return_fractional + integer, intent(out) :: ret_axis + real(4), dimension(2), intent(out) :: ret_location + type(intf_info_type) :: intf_info + + this_ptr = transfer(this, this_ptr) + structure_ptr = transfer(structure, structure_ptr) + intf_info = this_ptr%p%get_interface_location( & + structure=structure_ptr%p, & + axis=axis, & + return_fractional=return_fractional & + ) + + ret_location = intf_info%loc + ret_axis = intf_info%axis +end subroutine f90wrap_intf_gen__get_interface_location__binding__agt +!############################################################################### + + +!############################################################################### +! Interface generate procedures +!############################################################################### +subroutine f90wrap_intf_gen__generate__binding__agt( & + this, surface_lw, surface_up, & + thickness_lw, thickness_up, & + num_layers_lw, num_layers_up, & + reduce_matches, & + print_lattice_match_info, print_termination_info, print_shift_info, & + break_on_fail, icheck_term_pair, interface_idx, & + generate_structures, & + seed, verbose, exit_code, & + n0, n1) + use artemis__generator, only: artemis_generator_type + implicit none + + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + integer, intent(in), optional, dimension(n0) :: surface_lw + integer, intent(in), optional, dimension(n1) :: surface_up + real(4), intent(in), optional :: thickness_lw + real(4), intent(in), optional :: thickness_up + integer, intent(in), optional :: num_layers_lw + integer, intent(in), optional :: num_layers_up + logical, intent(in), optional :: reduce_matches + logical, intent(in), optional :: print_lattice_match_info + logical, intent(in), optional :: print_termination_info + logical, intent(in), optional :: print_shift_info + logical, intent(in), optional :: break_on_fail + integer, intent(in), optional :: icheck_term_pair + integer, intent(in), optional :: interface_idx + logical, intent(in), optional :: generate_structures + integer, intent(in), optional :: seed + integer, intent(in), optional :: verbose + integer, optional, intent(inout) :: exit_code + integer :: n0 + !f2py intent(hide), depend(surface_lw) :: n0 = shape(surface_lw,0) + integer :: n1 + !f2py intent(hide), depend(surface_up) :: n1 = shape(surface_up,0) + this_ptr = transfer(this, this_ptr) + call this_ptr%p%generate(surface_lw=surface_lw, surface_up=surface_up, thickness_lw=thickness_lw, & + thickness_up=thickness_up, num_layers_lw=num_layers_lw, num_layers_up=num_layers_up, & + reduce_matches=reduce_matches, & + print_lattice_match_info=print_lattice_match_info, print_termination_info=print_termination_info, & + print_shift_info=print_shift_info, break_on_fail=break_on_fail, icheck_term_pair=icheck_term_pair, & + interface_idx=interface_idx, generate_structures=generate_structures, seed=seed, verbose=verbose, & + exit_code=exit_code) +end subroutine f90wrap_intf_gen__generate__binding__agt + +subroutine f90wrap_intf_gen__regenerate__binding__agt(this, structure, interface_location, & + print_shift_info, seed, verbose, exit_code) + use artemis__generator, only: artemis_generator_type + use artemis__geom_rw, only: basis_type + implicit none + + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + type(basis_type_ptr_type) :: structure_ptr + integer, intent(in), dimension(2) :: structure + real(4), dimension(2), intent(in), optional :: interface_location + logical, intent(in), optional :: print_shift_info + integer, intent(in), optional :: seed + integer, intent(in), optional :: verbose + integer, optional, intent(inout) :: exit_code + this_ptr = transfer(this, this_ptr) + structure_ptr = transfer(structure, structure_ptr) + call this_ptr%p%regenerate(structure=structure_ptr%p, interface_location=interface_location, print_shift_info=print_shift_info, & + seed=seed, verbose=verbose, exit_code=exit_code) +end subroutine f90wrap_intf_gen__regenerate__binding__agt +!############################################################################### + + +!############################################################################### +! Handle the structures array +!############################################################################### +subroutine f90wrap_intf_gen__get_structures__binding__agt(this, ret_structures) + use artemis__generator, only: artemis_generator_type + use artemis__geom_rw, only: basis_type + implicit none + + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + + type basis_type_xnum_array + type(basis_type), dimension(:), allocatable :: items + end type basis_type_xnum_array + + type basis_type_xnum_array_ptr_type + type(basis_type_xnum_array), pointer :: p => NULL() + end type basis_type_xnum_array_ptr_type + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + integer, intent(out), dimension(2) :: ret_structures + type(basis_type_xnum_array_ptr_type) :: ret_structures_ptr + + this_ptr = transfer(this, this_ptr) + ret_structures_ptr%p%items = this_ptr%p%get_structures() + ret_structures = transfer(ret_structures_ptr,ret_structures) +end subroutine f90wrap_intf_gen__get_structures__binding__agt + +subroutine f90wrap_intf_gen__clear_structures__binding__agt(this) + use artemis__generator, only: artemis_generator_type + implicit none + + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + this_ptr = transfer(this, this_ptr) + call this_ptr%p%clear_structures() +end subroutine f90wrap_intf_gen__clear_structures__binding__agt + +subroutine f90wrap_retrieve_last_generated_structures(structures) + use artemis__geom_rw, only: basis_type + use artemis__structure_cache, only: retrieve_last_generated_structures + implicit none + + type basis_type_xnum_array + type(basis_type), dimension(:), allocatable :: items + end type basis_type_xnum_array + + type basis_type_xnum_array_ptr_type + type(basis_type_xnum_array), pointer :: p => NULL() + end type basis_type_xnum_array_ptr_type + integer, intent(inout), dimension(2) :: structures + type(basis_type_xnum_array_ptr_type) :: structures_ptr + + structures_ptr = transfer(structures, structures_ptr) + structures_ptr%p%items = retrieve_last_generated_structures() + structures = transfer(structures_ptr, structures) +end subroutine f90wrap_retrieve_last_generated_structures +!############################################################################### + + +!############################################################################### +! generated structures handling +!############################################################################### +subroutine f90wrap_artemis_gen_type__array_getitem__structures( & + f90wrap_this, f90wrap_i, structuresitem & +) + + use artemis__generator, only: artemis_generator_type + use artemis__geom_rw, only: basis_type + implicit none + + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + integer, intent(in) :: f90wrap_this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in) :: f90wrap_i + integer, intent(out) :: structuresitem(2) + type(basis_type_ptr_type) :: structures_ptr + + this_ptr = transfer(f90wrap_this, this_ptr) + if (allocated(this_ptr%p%structures)) then + if (f90wrap_i < 1 .or. f90wrap_i > size(this_ptr%p%structures)) then + call f90wrap_abort("array index out of range") + else + structures_ptr%p => this_ptr%p%structures(f90wrap_i) + structuresitem = transfer(structures_ptr,structuresitem) + endif + else + call f90wrap_abort("derived type array not allocated") + end if +end subroutine f90wrap_artemis_gen_type__array_getitem__structures + +subroutine f90wrap_artemis_gen_type__array_setitem__structures( & + f90wrap_this, f90wrap_i, structuresitem & +) + + use artemis__generator, only: artemis_generator_type + use artemis__geom_rw, only: basis_type + implicit none + + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + integer, intent(in) :: f90wrap_this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + integer, intent(in) :: f90wrap_i + integer, intent(in) :: structuresitem(2) + type(basis_type_ptr_type) :: structures_ptr + + this_ptr = transfer(f90wrap_this, this_ptr) + if (allocated(this_ptr%p%structures)) then + if (f90wrap_i < 1 .or. f90wrap_i > size(this_ptr%p%structures)) then + call f90wrap_abort("array index out of range") + else + structures_ptr = transfer(structuresitem,structures_ptr) + this_ptr%p%structures(f90wrap_i) = structures_ptr%p + endif + else + call f90wrap_abort("derived type array not allocated") + end if +end subroutine f90wrap_artemis_gen_type__array_setitem__structures + +subroutine f90wrap_artemis_gen_type__array_len__structures( & + f90wrap_this, f90wrap_n & +) + + use artemis__generator, only: artemis_generator_type + use artemis__geom_rw, only: basis_type + implicit none + + type artemis_generator_type_ptr_type + type(artemis_generator_type), pointer :: p => NULL() + end type artemis_generator_type_ptr_type + integer, intent(out) :: f90wrap_n + integer, intent(in) :: f90wrap_this(2) + type(artemis_generator_type_ptr_type) :: this_ptr + + this_ptr = transfer(f90wrap_this, this_ptr) + if (allocated(this_ptr%p%structures)) then + f90wrap_n = size(this_ptr%p%structures) + else + f90wrap_n = 0 + end if +end subroutine f90wrap_artemis_gen_type__array_len__structures +!############################################################################### + +! End of module artemis__generator defined in file ../fortran/lib/mod_intf_generator.f90 + diff --git a/src/wrapper/f90wrap_mod_geom_rw.f90 b/src/wrapper/f90wrap_mod_geom_rw.f90 new file mode 100644 index 0000000..9713c12 --- /dev/null +++ b/src/wrapper/f90wrap_mod_geom_rw.f90 @@ -0,0 +1,865 @@ +! Module artemis__geom_rw defined in file ../fortran/lib/mod_geom_rw.f90 + +subroutine f90wrap_species_type__array__atom(this, nd, dtype, dshape, dloc) + use artemis__geom_rw, only: species_type + use, intrinsic :: iso_c_binding, only : c_int + implicit none + type species_type_ptr_type + type(species_type), pointer :: p => NULL() + end type species_type_ptr_type + integer(c_int), intent(in) :: this(2) + type(species_type_ptr_type) :: this_ptr + integer(c_int), intent(out) :: nd + integer(c_int), intent(out) :: dtype + integer(c_int), dimension(10), intent(out) :: dshape + integer*8, intent(out) :: dloc + + nd = 2 + dtype = 11 + this_ptr = transfer(this, this_ptr) + if (allocated(this_ptr%p%atom)) then + dshape(1:2) = shape(this_ptr%p%atom) + dloc = loc(this_ptr%p%atom) + else + dloc = 0 + end if +end subroutine f90wrap_species_type__array__atom + +subroutine f90wrap_species_type__get__mass(this, f90wrap_mass) + use artemis__geom_rw, only: species_type + implicit none + type species_type_ptr_type + type(species_type), pointer :: p => NULL() + end type species_type_ptr_type + integer, intent(in) :: this(2) + type(species_type_ptr_type) :: this_ptr + real(4), intent(out) :: f90wrap_mass + + this_ptr = transfer(this, this_ptr) + f90wrap_mass = this_ptr%p%mass +end subroutine f90wrap_species_type__get__mass + +subroutine f90wrap_species_type__set__mass(this, f90wrap_mass) + use artemis__geom_rw, only: species_type + implicit none + type species_type_ptr_type + type(species_type), pointer :: p => NULL() + end type species_type_ptr_type + integer, intent(in) :: this(2) + type(species_type_ptr_type) :: this_ptr + real(4), intent(in) :: f90wrap_mass + + this_ptr = transfer(this, this_ptr) + this_ptr%p%mass = f90wrap_mass +end subroutine f90wrap_species_type__set__mass + +subroutine f90wrap_species_type__get__charge(this, f90wrap_charge) + use artemis__geom_rw, only: species_type + implicit none + type species_type_ptr_type + type(species_type), pointer :: p => NULL() + end type species_type_ptr_type + integer, intent(in) :: this(2) + type(species_type_ptr_type) :: this_ptr + real(4), intent(out) :: f90wrap_charge + + this_ptr = transfer(this, this_ptr) + f90wrap_charge = this_ptr%p%charge +end subroutine f90wrap_species_type__get__charge + +subroutine f90wrap_species_type__set__charge(this, f90wrap_charge) + use artemis__geom_rw, only: species_type + implicit none + type species_type_ptr_type + type(species_type), pointer :: p => NULL() + end type species_type_ptr_type + integer, intent(in) :: this(2) + type(species_type_ptr_type) :: this_ptr + real(4), intent(in) :: f90wrap_charge + + this_ptr = transfer(this, this_ptr) + this_ptr%p%charge = f90wrap_charge +end subroutine f90wrap_species_type__set__charge + +subroutine f90wrap_species_type__get__radius(this, f90wrap_radius) + use artemis__geom_rw, only: species_type + implicit none + type species_type_ptr_type + type(species_type), pointer :: p => NULL() + end type species_type_ptr_type + integer, intent(in) :: this(2) + type(species_type_ptr_type) :: this_ptr + real(4), intent(out) :: f90wrap_radius + + this_ptr = transfer(this, this_ptr) + f90wrap_radius = this_ptr%p%radius +end subroutine f90wrap_species_type__get__radius + +subroutine f90wrap_species_type__set__radius(this, f90wrap_radius) + use artemis__geom_rw, only: species_type + implicit none + type species_type_ptr_type + type(species_type), pointer :: p => NULL() + end type species_type_ptr_type + integer, intent(in) :: this(2) + type(species_type_ptr_type) :: this_ptr + real(4), intent(in) :: f90wrap_radius + + this_ptr = transfer(this, this_ptr) + this_ptr%p%radius = f90wrap_radius +end subroutine f90wrap_species_type__set__radius + +subroutine f90wrap_species_type__get__name(this, f90wrap_name) + use artemis__geom_rw, only: species_type + implicit none + type species_type_ptr_type + type(species_type), pointer :: p => NULL() + end type species_type_ptr_type + integer, intent(in) :: this(2) + type(species_type_ptr_type) :: this_ptr + character(3), intent(out) :: f90wrap_name + + this_ptr = transfer(this, this_ptr) + f90wrap_name = this_ptr%p%name +end subroutine f90wrap_species_type__get__name + +subroutine f90wrap_species_type__set__name(this, f90wrap_name) + use artemis__geom_rw, only: species_type + implicit none + type species_type_ptr_type + type(species_type), pointer :: p => NULL() + end type species_type_ptr_type + integer, intent(in) :: this(2) + type(species_type_ptr_type) :: this_ptr + character(3), intent(in) :: f90wrap_name + + this_ptr = transfer(this, this_ptr) + this_ptr%p%name = f90wrap_name +end subroutine f90wrap_species_type__set__name + +subroutine f90wrap_species_type__get__num(this, f90wrap_num) + use artemis__geom_rw, only: species_type + implicit none + type species_type_ptr_type + type(species_type), pointer :: p => NULL() + end type species_type_ptr_type + integer, intent(in) :: this(2) + type(species_type_ptr_type) :: this_ptr + integer, intent(out) :: f90wrap_num + + this_ptr = transfer(this, this_ptr) + f90wrap_num = this_ptr%p%num +end subroutine f90wrap_species_type__get__num + +subroutine f90wrap_species_type__set__num(this, f90wrap_num) + use artemis__geom_rw, only: species_type + implicit none + type species_type_ptr_type + type(species_type), pointer :: p => NULL() + end type species_type_ptr_type + integer, intent(in) :: this(2) + type(species_type_ptr_type) :: this_ptr + integer, intent(in) :: f90wrap_num + + this_ptr = transfer(this, this_ptr) + this_ptr%p%num = f90wrap_num +end subroutine f90wrap_species_type__set__num + +subroutine f90wrap_geom_rw__species_type_initialise(this) + use artemis__geom_rw, only: species_type + implicit none + + type species_type_ptr_type + type(species_type), pointer :: p => NULL() + end type species_type_ptr_type + type(species_type_ptr_type) :: this_ptr + integer, intent(out), dimension(2) :: this + allocate(this_ptr%p) + this = transfer(this_ptr, this) +end subroutine f90wrap_geom_rw__species_type_initialise + +subroutine f90wrap_geom_rw__species_type_finalise(this) + use artemis__geom_rw, only: species_type + implicit none + + type species_type_ptr_type + type(species_type), pointer :: p => NULL() + end type species_type_ptr_type + type(species_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + this_ptr = transfer(this, this_ptr) + deallocate(this_ptr%p) +end subroutine f90wrap_geom_rw__species_type_finalise + +subroutine f90wrap_basis_type__array_getitem__spec(f90wrap_this, f90wrap_i, specitem) + + use artemis__geom_rw, only: basis_type, species_type + implicit none + + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + type species_type_ptr_type + type(species_type), pointer :: p => NULL() + end type species_type_ptr_type + integer, intent(in) :: f90wrap_this(2) + type(basis_type_ptr_type) :: this_ptr + integer, intent(in) :: f90wrap_i + integer, intent(out) :: specitem(2) + type(species_type_ptr_type) :: spec_ptr + + this_ptr = transfer(f90wrap_this, this_ptr) + if (allocated(this_ptr%p%spec)) then + if (f90wrap_i < 1 .or. f90wrap_i > size(this_ptr%p%spec)) then + call f90wrap_abort("array index out of range") + else + spec_ptr%p => this_ptr%p%spec(f90wrap_i) + specitem = transfer(spec_ptr,specitem) + endif + else + call f90wrap_abort("derived type array not allocated") + end if +end subroutine f90wrap_basis_type__array_getitem__spec + +subroutine f90wrap_basis_type__array_setitem__spec(f90wrap_this, f90wrap_i, specitem) + + use artemis__geom_rw, only: basis_type, species_type + implicit none + + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + type species_type_ptr_type + type(species_type), pointer :: p => NULL() + end type species_type_ptr_type + integer, intent(in) :: f90wrap_this(2) + type(basis_type_ptr_type) :: this_ptr + integer, intent(in) :: f90wrap_i + integer, intent(in) :: specitem(2) + type(species_type_ptr_type) :: spec_ptr + + this_ptr = transfer(f90wrap_this, this_ptr) + if (allocated(this_ptr%p%spec)) then + if (f90wrap_i < 1 .or. f90wrap_i > size(this_ptr%p%spec)) then + call f90wrap_abort("array index out of range") + else + spec_ptr = transfer(specitem,spec_ptr) + this_ptr%p%spec(f90wrap_i) = spec_ptr%p + endif + else + call f90wrap_abort("derived type array not allocated") + end if +end subroutine f90wrap_basis_type__array_setitem__spec + +subroutine f90wrap_basis_type__array_len__spec(f90wrap_this, f90wrap_n) + + use artemis__geom_rw, only: basis_type, species_type + implicit none + + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + type species_type_ptr_type + type(species_type), pointer :: p => NULL() + end type species_type_ptr_type + integer, intent(out) :: f90wrap_n + integer, intent(in) :: f90wrap_this(2) + type(basis_type_ptr_type) :: this_ptr + + this_ptr = transfer(f90wrap_this, this_ptr) + if (allocated(this_ptr%p%spec)) then + f90wrap_n = size(this_ptr%p%spec) + else + f90wrap_n = 0 + end if +end subroutine f90wrap_basis_type__array_len__spec + +subroutine f90wrap_basis_type__get__nspec(this, f90wrap_nspec) + use artemis__geom_rw, only: basis_type + implicit none + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + integer, intent(in) :: this(2) + type(basis_type_ptr_type) :: this_ptr + integer, intent(out) :: f90wrap_nspec + + this_ptr = transfer(this, this_ptr) + f90wrap_nspec = this_ptr%p%nspec +end subroutine f90wrap_basis_type__get__nspec + +subroutine f90wrap_basis_type__set__nspec(this, f90wrap_nspec) + use artemis__geom_rw, only: basis_type + implicit none + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + integer, intent(in) :: this(2) + type(basis_type_ptr_type) :: this_ptr + integer, intent(in) :: f90wrap_nspec + + this_ptr = transfer(this, this_ptr) + this_ptr%p%nspec = f90wrap_nspec +end subroutine f90wrap_basis_type__set__nspec + +subroutine f90wrap_basis_type__get__natom(this, f90wrap_natom) + use artemis__geom_rw, only: basis_type + implicit none + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + integer, intent(in) :: this(2) + type(basis_type_ptr_type) :: this_ptr + integer, intent(out) :: f90wrap_natom + + this_ptr = transfer(this, this_ptr) + f90wrap_natom = this_ptr%p%natom +end subroutine f90wrap_basis_type__get__natom + +subroutine f90wrap_basis_type__set__natom(this, f90wrap_natom) + use artemis__geom_rw, only: basis_type + implicit none + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + integer, intent(in) :: this(2) + type(basis_type_ptr_type) :: this_ptr + integer, intent(in) :: f90wrap_natom + + this_ptr = transfer(this, this_ptr) + this_ptr%p%natom = f90wrap_natom +end subroutine f90wrap_basis_type__set__natom + +subroutine f90wrap_basis_type__get__energy(this, f90wrap_energy) + use artemis__geom_rw, only: basis_type + implicit none + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + integer, intent(in) :: this(2) + type(basis_type_ptr_type) :: this_ptr + real(4), intent(out) :: f90wrap_energy + + this_ptr = transfer(this, this_ptr) + f90wrap_energy = this_ptr%p%energy +end subroutine f90wrap_basis_type__get__energy + +subroutine f90wrap_basis_type__set__energy(this, f90wrap_energy) + use artemis__geom_rw, only: basis_type + implicit none + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + integer, intent(in) :: this(2) + type(basis_type_ptr_type) :: this_ptr + real(4), intent(in) :: f90wrap_energy + + this_ptr = transfer(this, this_ptr) + this_ptr%p%energy = f90wrap_energy +end subroutine f90wrap_basis_type__set__energy + +subroutine f90wrap_basis_type__array__lat(this, nd, dtype, dshape, dloc) + use artemis__geom_rw, only: basis_type + use, intrinsic :: iso_c_binding, only : c_int + implicit none + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + integer(c_int), intent(in) :: this(2) + type(basis_type_ptr_type) :: this_ptr + integer(c_int), intent(out) :: nd + integer(c_int), intent(out) :: dtype + integer(c_int), dimension(10), intent(out) :: dshape + integer*8, intent(out) :: dloc + + nd = 2 + dtype = 11 + this_ptr = transfer(this, this_ptr) + dshape(1:2) = shape(this_ptr%p%lat) + dloc = loc(this_ptr%p%lat) +end subroutine f90wrap_basis_type__array__lat + +subroutine f90wrap_basis_type__get__lcart(this, f90wrap_lcart) + use artemis__geom_rw, only: basis_type + implicit none + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + integer, intent(in) :: this(2) + type(basis_type_ptr_type) :: this_ptr + logical, intent(out) :: f90wrap_lcart + + this_ptr = transfer(this, this_ptr) + f90wrap_lcart = this_ptr%p%lcart +end subroutine f90wrap_basis_type__get__lcart + +subroutine f90wrap_basis_type__set__lcart(this, f90wrap_lcart) + use artemis__geom_rw, only: basis_type + implicit none + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + integer, intent(in) :: this(2) + type(basis_type_ptr_type) :: this_ptr + logical, intent(in) :: f90wrap_lcart + + this_ptr = transfer(this, this_ptr) + this_ptr%p%lcart = f90wrap_lcart +end subroutine f90wrap_basis_type__set__lcart + +subroutine f90wrap_basis_type__array__pbc(this, nd, dtype, dshape, dloc) + use artemis__geom_rw, only: basis_type + use, intrinsic :: iso_c_binding, only : c_int + implicit none + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + integer(c_int), intent(in) :: this(2) + type(basis_type_ptr_type) :: this_ptr + integer(c_int), intent(out) :: nd + integer(c_int), intent(out) :: dtype + integer(c_int), dimension(10), intent(out) :: dshape + integer*8, intent(out) :: dloc + + nd = 1 + dtype = 5 + this_ptr = transfer(this, this_ptr) + dshape(1:1) = shape(this_ptr%p%pbc) + dloc = loc(this_ptr%p%pbc) +end subroutine f90wrap_basis_type__array__pbc + +subroutine f90wrap_basis_type__get__sysname(this, f90wrap_sysname) + use artemis__geom_rw, only: basis_type + implicit none + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + integer, intent(in) :: this(2) + type(basis_type_ptr_type) :: this_ptr + character(128), intent(out) :: f90wrap_sysname + + this_ptr = transfer(this, this_ptr) + f90wrap_sysname = this_ptr%p%sysname +end subroutine f90wrap_basis_type__get__sysname + +subroutine f90wrap_basis_type__set__sysname(this, f90wrap_sysname) + use artemis__geom_rw, only: basis_type + implicit none + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + integer, intent(in) :: this(2) + type(basis_type_ptr_type) :: this_ptr + character(128), intent(in) :: f90wrap_sysname + + this_ptr = transfer(this, this_ptr) + this_ptr%p%sysname = f90wrap_sysname +end subroutine f90wrap_basis_type__set__sysname + +subroutine f90wrap_geom_rw__basis_type_initialise(this) + use artemis__geom_rw, only: basis_type + implicit none + + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + type(basis_type_ptr_type) :: this_ptr + integer, intent(out), dimension(2) :: this + allocate(this_ptr%p) + this = transfer(this_ptr, this) +end subroutine f90wrap_geom_rw__basis_type_initialise + +subroutine f90wrap_geom_rw__basis_type_finalise(this) + use artemis__geom_rw, only: basis_type + implicit none + + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + type(basis_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + this_ptr = transfer(this, this_ptr) + deallocate(this_ptr%p) +end subroutine f90wrap_geom_rw__basis_type_finalise + + + + + +subroutine f90wrap_basis_type_xnum_array__array_getitem__items( & + this, f90wrap_i, itemsitem) + use artemis__geom_rw, only: basis_type + implicit none + + type basis_type_xnum_array + type(basis_type), dimension(:), allocatable :: items + end type basis_type_xnum_array + + type basis_type_xnum_array_ptr_type + type(basis_type_xnum_array), pointer :: p => NULL() + end type basis_type_xnum_array_ptr_type + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + integer, intent(in), dimension(2) :: this + type(basis_type_xnum_array_ptr_type) :: this_ptr + integer, intent(in) :: f90wrap_i + integer, intent(out) :: itemsitem(2) + type(basis_type_ptr_type) :: items_ptr + + this_ptr = transfer(this, this_ptr) + if (f90wrap_i < 1 .or. f90wrap_i > size(this_ptr%p%items)) then + call f90wrap_abort("array index out of range") + else + items_ptr%p => this_ptr%p%items(f90wrap_i) + itemsitem = transfer(items_ptr,itemsitem) + endif +end subroutine f90wrap_basis_type_xnum_array__array_getitem__items + +subroutine f90wrap_basis_type_xnum_array__array_setitem__items(this, f90wrap_i, itemsitem) + use artemis__geom_rw, only: basis_type + implicit none + + type basis_type_xnum_array + type(basis_type), dimension(:), allocatable :: items + end type basis_type_xnum_array + + type basis_type_xnum_array_ptr_type + type(basis_type_xnum_array), pointer :: p => NULL() + end type basis_type_xnum_array_ptr_type + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + integer, intent(in), dimension(2) :: this + type(basis_type_xnum_array_ptr_type) :: this_ptr + integer, intent(in) :: f90wrap_i + integer, intent(out) :: itemsitem(2) + type(basis_type_ptr_type) :: items_ptr + + this_ptr = transfer(this, this_ptr) + if (f90wrap_i < 1 .or. f90wrap_i > size(this_ptr%p%items)) then + call f90wrap_abort("array index out of range") + else + items_ptr = transfer(itemsitem,items_ptr) + this_ptr%p%items(f90wrap_i) = items_ptr%p + endif +end subroutine f90wrap_basis_type_xnum_array__array_setitem__items + +subroutine f90wrap_basis_type_xnum_array__array_len__items(this, f90wrap_n) + use artemis__geom_rw, only: basis_type + implicit none + + type basis_type_xnum_array + type(basis_type), dimension(:), allocatable :: items + end type basis_type_xnum_array + + type basis_type_xnum_array_ptr_type + type(basis_type_xnum_array), pointer :: p => NULL() + end type basis_type_xnum_array_ptr_type + integer, intent(in), dimension(2) :: this + type(basis_type_xnum_array_ptr_type) :: this_ptr + integer, intent(out) :: f90wrap_n + this_ptr = transfer(this, this_ptr) + f90wrap_n = size(this_ptr%p%items) +end subroutine f90wrap_basis_type_xnum_array__array_len__items + +subroutine f90wrap_basis_type_xnum_array__array_alloc__items(this, num) + use artemis__geom_rw, only: basis_type + implicit none + + type basis_type_xnum_array + type(basis_type), dimension(:), allocatable :: items + end type basis_type_xnum_array + + type basis_type_xnum_array_ptr_type + type(basis_type_xnum_array), pointer :: p => NULL() + end type basis_type_xnum_array_ptr_type + type(basis_type_xnum_array_ptr_type) :: this_ptr + integer, intent(in) :: num + integer, intent(inout), dimension(2) :: this + + this_ptr = transfer(this, this_ptr) + allocate(this_ptr%p%items(num)) + this = transfer(this_ptr, this) +end subroutine f90wrap_basis_type_xnum_array__array_alloc__items + +subroutine f90wrap_basis_type_xnum_array__array_dealloc__items(this) + use artemis__geom_rw, only: basis_type + implicit none + + type basis_type_xnum_array + type(basis_type), dimension(:), allocatable :: items + end type basis_type_xnum_array + + type basis_type_xnum_array_ptr_type + type(basis_type_xnum_array), pointer :: p => NULL() + end type basis_type_xnum_array_ptr_type + type(basis_type_xnum_array_ptr_type) :: this_ptr + integer, intent(inout), dimension(2) :: this + + this_ptr = transfer(this, this_ptr) + deallocate(this_ptr%p%items) + this = transfer(this_ptr, this) +end subroutine f90wrap_basis_type_xnum_array__array_dealloc__items + +subroutine f90wrap_geom_rw__basis_type_xnum_array_initialise(this) + use artemis__geom_rw, only: basis_type + implicit none + + type basis_type_xnum_array + type(basis_type), dimension(:), allocatable :: items + end type basis_type_xnum_array + + type basis_type_xnum_array_ptr_type + type(basis_type_xnum_array), pointer :: p => NULL() + end type basis_type_xnum_array_ptr_type + type(basis_type_xnum_array_ptr_type) :: this_ptr + integer, intent(out), dimension(2) :: this + allocate(this_ptr%p) + this = transfer(this_ptr, this) +end subroutine f90wrap_geom_rw__basis_type_xnum_array_initialise + +subroutine f90wrap_geom_rw__basis_type_xnum_array_finalise(this) + use artemis__geom_rw, only: basis_type + implicit none + + type basis_type_xnum_array + type(basis_type), dimension(:), allocatable :: items + end type basis_type_xnum_array + + type basis_type_xnum_array_ptr_type + type(basis_type_xnum_array), pointer :: p => NULL() + end type basis_type_xnum_array_ptr_type + type(basis_type_xnum_array_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + this_ptr = transfer(this, this_ptr) + deallocate(this_ptr%p) +end subroutine f90wrap_geom_rw__basis_type_xnum_array_finalise + + + + +subroutine f90wrap_geom_rw__allocate_species__binding__basis_type( & + this, num_species, species_symbols, species_count, atoms, n0, & + n1, n2, n3) + use artemis__geom_rw, only: basis_type + implicit none + + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + type(basis_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + integer, intent(in), optional :: num_species + character(3), intent(in), optional, dimension(n0) :: species_symbols + integer, intent(in), optional, dimension(n1) :: species_count + real(4), intent(in), optional, dimension(n2,n3) :: atoms + integer :: n0 + !f2py intent(hide), depend(species_symbols) :: n0 = shape(species_symbols,0) + integer :: n1 + !f2py intent(hide), depend(species_count) :: n1 = shape(species_count,0) + integer :: n2 + !f2py intent(hide), depend(atoms) :: n2 = shape(atoms,0) + integer :: n3 + !f2py intent(hide), depend(atoms) :: n3 = shape(atoms,1) + this_ptr = transfer(this, this_ptr) + call this_ptr%p%allocate_species( & + num_species=num_species, & + species_symbols=species_symbols, & + species_count=species_count, & + atoms=atoms & + ) +end subroutine f90wrap_geom_rw__allocate_species__binding__basis_type + +subroutine f90wrap_geom_rw__convert__binding__basis_type(this) + use artemis__geom_rw, only: basis_type + implicit none + + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + type(basis_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + this_ptr = transfer(this, this_ptr) + call this_ptr%p%convert() +end subroutine f90wrap_geom_rw__convert__binding__basis_type + +subroutine f90wrap_geom_rw__change_lattice__binding__basis_type(this, lattice) + use artemis__geom_rw, only: basis_type + implicit none + + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + type(basis_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + real(4), dimension(3,3), intent(in) :: lattice + this_ptr = transfer(this, this_ptr) + call this_ptr%p%change_lattice(lattice=lattice) +end subroutine f90wrap_geom_rw__change_lattice__binding__basis_type + +subroutine f90wrap_geom_rw__normalise__binding__basis_type(this, ceil_val, floor_coords, round_coords, & + zero_round) + use artemis__geom_rw, only: basis_type + implicit none + + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + type(basis_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + real(4), intent(in), optional :: ceil_val + logical, intent(in), optional :: floor_coords + logical, intent(in), optional :: round_coords + real(4), intent(in), optional :: zero_round + this_ptr = transfer(this, this_ptr) + call this_ptr%p%normalise(ceil_val=ceil_val, floor_coords=floor_coords, round_coords=round_coords, & + zero_round=zero_round) +end subroutine f90wrap_geom_rw__normalise__binding__basis_type + +subroutine f90wrap_geom_rw__copy__binding__basis_type(this, basis, length) + use artemis__geom_rw, only: basis_type + implicit none + + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + type(basis_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + type(basis_type_ptr_type) :: basis_ptr + integer, intent(in), dimension(2) :: basis + integer, intent(in), optional :: length + this_ptr = transfer(this, this_ptr) + basis_ptr = transfer(basis, basis_ptr) + call this_ptr%p%copy(basis=basis_ptr%p, length=length) +end subroutine f90wrap_geom_rw__copy__binding__basis_type + +subroutine f90wrap_geom_rw__get_lattice_constants__binding__basis_type(this, ret_output, radians) + use artemis__geom_rw, only: basis_type + implicit none + + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + type(basis_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + real(4), dimension(2,3), intent(out) :: ret_output + logical, intent(in), optional :: radians + this_ptr = transfer(this, this_ptr) + ret_output = this_ptr%p%get_lattice_constants(radians=radians) +end subroutine f90wrap_geom_rw__get_lattice_constants__binding__basis_type + +subroutine f90wrap_geom_rw__remove_atom__binding__basis_type(this, ispec, iatom) + use artemis__geom_rw, only: basis_type + implicit none + + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + type(basis_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + integer, intent(in) :: ispec + integer, intent(in) :: iatom + this_ptr = transfer(this, this_ptr) + call this_ptr%p%remove_atom(ispec=ispec, iatom=iatom) +end subroutine f90wrap_geom_rw__remove_atom__binding__basis_type + +subroutine f90wrap_geom_rw__remove_atoms__binding__basis_type(this, atoms, n0, n1) + use artemis__geom_rw, only: basis_type + implicit none + + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + type(basis_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + integer, intent(in), dimension(n0,n1) :: atoms + integer :: n0 + !f2py intent(hide), depend(atoms) :: n0 = shape(atoms,0) + integer :: n1 + !f2py intent(hide), depend(atoms) :: n1 = shape(atoms,1) + this_ptr = transfer(this, this_ptr) + call this_ptr%p%remove_atoms(atoms=atoms) +end subroutine f90wrap_geom_rw__remove_atoms__binding__basis_type + +subroutine f90wrap_geom_rw__geom_read(unit, basis, length, iostat) + use artemis__geom_rw, only: geom_read, basis_type + implicit none + + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + integer, intent(in) :: unit + type(basis_type_ptr_type) :: basis_ptr + integer, intent(out), dimension(2) :: basis + integer, optional, intent(in) :: length + integer, optional, intent(inout) :: iostat + allocate(basis_ptr%p) + call geom_read(UNIT=unit, basis=basis_ptr%p, length=length, iostat=iostat) + basis = transfer(basis_ptr, basis) +end subroutine f90wrap_geom_rw__geom_read + +subroutine f90wrap_geom_rw__geom_write(unit, basis) + use artemis__geom_rw, only: geom_write, basis_type + implicit none + + type basis_type_ptr_type + type(basis_type), pointer :: p => NULL() + end type basis_type_ptr_type + integer, intent(in) :: unit + type(basis_type_ptr_type) :: basis_ptr + integer, intent(in), dimension(2) :: basis + basis_ptr = transfer(basis, basis_ptr) + call geom_write(UNIT=unit, basis=basis_ptr%p) +end subroutine f90wrap_geom_rw__geom_write + +subroutine f90wrap_geom_rw__get_element_properties(element, charge, mass, radius) + use artemis__geom_rw, only: get_element_properties + implicit none + + character(3), intent(in) :: element + real(4), optional, intent(inout) :: charge + real(4), optional, intent(inout) :: mass + real(4), optional, intent(inout) :: radius + call get_element_properties( & + element=element, & + charge=charge, & + mass=mass, & + radius=radius & + ) +end subroutine f90wrap_geom_rw__get_element_properties + +subroutine f90wrap_geom_rw__get__igeom_input(f90wrap_igeom_input) + use artemis__geom_rw, only: artemis__geom_rw_igeom_input => igeom_input + implicit none + integer, intent(out) :: f90wrap_igeom_input + + f90wrap_igeom_input = artemis__geom_rw_igeom_input +end subroutine f90wrap_geom_rw__get__igeom_input + +subroutine f90wrap_geom_rw__set__igeom_input(f90wrap_igeom_input) + use artemis__geom_rw, only: artemis__geom_rw_igeom_input => igeom_input + implicit none + integer, intent(in) :: f90wrap_igeom_input + + artemis__geom_rw_igeom_input = f90wrap_igeom_input +end subroutine f90wrap_geom_rw__set__igeom_input + +subroutine f90wrap_geom_rw__get__igeom_output(f90wrap_igeom_output) + use artemis__geom_rw, only: artemis__geom_rw_igeom_output => igeom_output + implicit none + integer, intent(out) :: f90wrap_igeom_output + + f90wrap_igeom_output = artemis__geom_rw_igeom_output +end subroutine f90wrap_geom_rw__get__igeom_output + +subroutine f90wrap_geom_rw__set__igeom_output(f90wrap_igeom_output) + use artemis__geom_rw, only: artemis__geom_rw_igeom_output => igeom_output + implicit none + integer, intent(in) :: f90wrap_igeom_output + + artemis__geom_rw_igeom_output = f90wrap_igeom_output +end subroutine f90wrap_geom_rw__set__igeom_output + +! End of module artemis__geom_rw defined in file ../fortran/lib/mod_geom_rw.f90 + diff --git a/src/wrapper/f90wrap_mod_misc_types.f90 b/src/wrapper/f90wrap_mod_misc_types.f90 new file mode 100644 index 0000000..b96d092 --- /dev/null +++ b/src/wrapper/f90wrap_mod_misc_types.f90 @@ -0,0 +1,401 @@ +! Module artemis__misc_types defined in file ../fortran/lib/mod_misc_types.f90 + +subroutine f90wrap_struc_data_type__get__match_idx(this, f90wrap_match_idx) + use artemis__misc_types, only: struc_data_type + implicit none + type struc_data_type_ptr_type + type(struc_data_type), pointer :: p => NULL() + end type struc_data_type_ptr_type + integer, intent(in) :: this(2) + type(struc_data_type_ptr_type) :: this_ptr + integer, intent(out) :: f90wrap_match_idx + + this_ptr = transfer(this, this_ptr) + f90wrap_match_idx = this_ptr%p%match_idx +end subroutine f90wrap_struc_data_type__get__match_idx + +subroutine f90wrap_struc_data_type__set__match_idx(this, f90wrap_match_idx) + use artemis__misc_types, only: struc_data_type + implicit none + type struc_data_type_ptr_type + type(struc_data_type), pointer :: p => NULL() + end type struc_data_type_ptr_type + integer, intent(in) :: this(2) + type(struc_data_type_ptr_type) :: this_ptr + integer, intent(in) :: f90wrap_match_idx + + this_ptr = transfer(this, this_ptr) + this_ptr%p%match_idx = f90wrap_match_idx +end subroutine f90wrap_struc_data_type__set__match_idx + +subroutine f90wrap_struc_data_type__get__shift_idx(this, f90wrap_shift_idx) + use artemis__misc_types, only: struc_data_type + implicit none + type struc_data_type_ptr_type + type(struc_data_type), pointer :: p => NULL() + end type struc_data_type_ptr_type + integer, intent(in) :: this(2) + type(struc_data_type_ptr_type) :: this_ptr + integer, intent(out) :: f90wrap_shift_idx + + this_ptr = transfer(this, this_ptr) + f90wrap_shift_idx = this_ptr%p%shift_idx +end subroutine f90wrap_struc_data_type__get__shift_idx + +subroutine f90wrap_struc_data_type__set__shift_idx(this, f90wrap_shift_idx) + use artemis__misc_types, only: struc_data_type + implicit none + type struc_data_type_ptr_type + type(struc_data_type), pointer :: p => NULL() + end type struc_data_type_ptr_type + integer, intent(in) :: this(2) + type(struc_data_type_ptr_type) :: this_ptr + integer, intent(in) :: f90wrap_shift_idx + + this_ptr = transfer(this, this_ptr) + this_ptr%p%shift_idx = f90wrap_shift_idx +end subroutine f90wrap_struc_data_type__set__shift_idx + +subroutine f90wrap_struc_data_type__get__swap_idx(this, f90wrap_swap_idx) + use artemis__misc_types, only: struc_data_type + implicit none + type struc_data_type_ptr_type + type(struc_data_type), pointer :: p => NULL() + end type struc_data_type_ptr_type + integer, intent(in) :: this(2) + type(struc_data_type_ptr_type) :: this_ptr + integer, intent(out) :: f90wrap_swap_idx + + this_ptr = transfer(this, this_ptr) + f90wrap_swap_idx = this_ptr%p%swap_idx +end subroutine f90wrap_struc_data_type__get__swap_idx + +subroutine f90wrap_struc_data_type__set__swap_idx(this, f90wrap_swap_idx) + use artemis__misc_types, only: struc_data_type + implicit none + type struc_data_type_ptr_type + type(struc_data_type), pointer :: p => NULL() + end type struc_data_type_ptr_type + integer, intent(in) :: this(2) + type(struc_data_type_ptr_type) :: this_ptr + integer, intent(in) :: f90wrap_swap_idx + + this_ptr = transfer(this, this_ptr) + this_ptr%p%swap_idx = f90wrap_swap_idx +end subroutine f90wrap_struc_data_type__set__swap_idx + +subroutine f90wrap_struc_data_type__get__from_pricel_lw(this, f90wrap_from_pricel_lw) + use artemis__misc_types, only: struc_data_type + implicit none + type struc_data_type_ptr_type + type(struc_data_type), pointer :: p => NULL() + end type struc_data_type_ptr_type + integer, intent(in) :: this(2) + type(struc_data_type_ptr_type) :: this_ptr + logical, intent(out) :: f90wrap_from_pricel_lw + + this_ptr = transfer(this, this_ptr) + f90wrap_from_pricel_lw = this_ptr%p%from_pricel_lw +end subroutine f90wrap_struc_data_type__get__from_pricel_lw + +subroutine f90wrap_struc_data_type__set__from_pricel_lw(this, f90wrap_from_pricel_lw) + use artemis__misc_types, only: struc_data_type + implicit none + type struc_data_type_ptr_type + type(struc_data_type), pointer :: p => NULL() + end type struc_data_type_ptr_type + integer, intent(in) :: this(2) + type(struc_data_type_ptr_type) :: this_ptr + logical, intent(in) :: f90wrap_from_pricel_lw + + this_ptr = transfer(this, this_ptr) + this_ptr%p%from_pricel_lw = f90wrap_from_pricel_lw +end subroutine f90wrap_struc_data_type__set__from_pricel_lw + +subroutine f90wrap_struc_data_type__get__from_pricel_up(this, f90wrap_from_pricel_up) + use artemis__misc_types, only: struc_data_type + implicit none + type struc_data_type_ptr_type + type(struc_data_type), pointer :: p => NULL() + end type struc_data_type_ptr_type + integer, intent(in) :: this(2) + type(struc_data_type_ptr_type) :: this_ptr + logical, intent(out) :: f90wrap_from_pricel_up + + this_ptr = transfer(this, this_ptr) + f90wrap_from_pricel_up = this_ptr%p%from_pricel_up +end subroutine f90wrap_struc_data_type__get__from_pricel_up + +subroutine f90wrap_struc_data_type__set__from_pricel_up(this, f90wrap_from_pricel_up) + use artemis__misc_types, only: struc_data_type + implicit none + type struc_data_type_ptr_type + type(struc_data_type), pointer :: p => NULL() + end type struc_data_type_ptr_type + integer, intent(in) :: this(2) + type(struc_data_type_ptr_type) :: this_ptr + logical, intent(in) :: f90wrap_from_pricel_up + + this_ptr = transfer(this, this_ptr) + this_ptr%p%from_pricel_up = f90wrap_from_pricel_up +end subroutine f90wrap_struc_data_type__set__from_pricel_up + +subroutine f90wrap_struc_data_type__array__term_lw_idx(this, nd, dtype, dshape, dloc) + use artemis__misc_types, only: struc_data_type + use, intrinsic :: iso_c_binding, only : c_int + implicit none + type struc_data_type_ptr_type + type(struc_data_type), pointer :: p => NULL() + end type struc_data_type_ptr_type + integer(c_int), intent(in) :: this(2) + type(struc_data_type_ptr_type) :: this_ptr + integer(c_int), intent(out) :: nd + integer(c_int), intent(out) :: dtype + integer(c_int), dimension(10), intent(out) :: dshape + integer*8, intent(out) :: dloc + + nd = 1 + dtype = 5 + this_ptr = transfer(this, this_ptr) + dshape(1:1) = shape(this_ptr%p%term_lw_idx) + dloc = loc(this_ptr%p%term_lw_idx) +end subroutine f90wrap_struc_data_type__array__term_lw_idx + +subroutine f90wrap_struc_data_type__array__term_up_idx(this, nd, dtype, dshape, dloc) + use artemis__misc_types, only: struc_data_type + use, intrinsic :: iso_c_binding, only : c_int + implicit none + type struc_data_type_ptr_type + type(struc_data_type), pointer :: p => NULL() + end type struc_data_type_ptr_type + integer(c_int), intent(in) :: this(2) + type(struc_data_type_ptr_type) :: this_ptr + integer(c_int), intent(out) :: nd + integer(c_int), intent(out) :: dtype + integer(c_int), dimension(10), intent(out) :: dshape + integer*8, intent(out) :: dloc + + nd = 1 + dtype = 5 + this_ptr = transfer(this, this_ptr) + dshape(1:1) = shape(this_ptr%p%term_up_idx) + dloc = loc(this_ptr%p%term_up_idx) +end subroutine f90wrap_struc_data_type__array__term_up_idx + +subroutine f90wrap_struc_data_type__array__transform_lw(this, nd, dtype, dshape, dloc) + use artemis__misc_types, only: struc_data_type + use, intrinsic :: iso_c_binding, only : c_int + implicit none + type struc_data_type_ptr_type + type(struc_data_type), pointer :: p => NULL() + end type struc_data_type_ptr_type + integer(c_int), intent(in) :: this(2) + type(struc_data_type_ptr_type) :: this_ptr + integer(c_int), intent(out) :: nd + integer(c_int), intent(out) :: dtype + integer(c_int), dimension(10), intent(out) :: dshape + integer*8, intent(out) :: dloc + + nd = 2 + dtype = 5 + this_ptr = transfer(this, this_ptr) + dshape(1:2) = shape(this_ptr%p%transform_lw) + dloc = loc(this_ptr%p%transform_lw) +end subroutine f90wrap_struc_data_type__array__transform_lw + +subroutine f90wrap_struc_data_type__array__transform_up(this, nd, dtype, dshape, dloc) + use artemis__misc_types, only: struc_data_type + use, intrinsic :: iso_c_binding, only : c_int + implicit none + type struc_data_type_ptr_type + type(struc_data_type), pointer :: p => NULL() + end type struc_data_type_ptr_type + integer(c_int), intent(in) :: this(2) + type(struc_data_type_ptr_type) :: this_ptr + integer(c_int), intent(out) :: nd + integer(c_int), intent(out) :: dtype + integer(c_int), dimension(10), intent(out) :: dshape + integer*8, intent(out) :: dloc + + nd = 2 + dtype = 5 + this_ptr = transfer(this, this_ptr) + dshape(1:2) = shape(this_ptr%p%transform_up) + dloc = loc(this_ptr%p%transform_up) +end subroutine f90wrap_struc_data_type__array__transform_up + +subroutine f90wrap_struc_data_type__get__approx_thickness_lw(this, f90wrap_approx_thickness_lw) + use artemis__misc_types, only: struc_data_type + implicit none + type struc_data_type_ptr_type + type(struc_data_type), pointer :: p => NULL() + end type struc_data_type_ptr_type + integer, intent(in) :: this(2) + type(struc_data_type_ptr_type) :: this_ptr + real(4), intent(out) :: f90wrap_approx_thickness_lw + + this_ptr = transfer(this, this_ptr) + f90wrap_approx_thickness_lw = this_ptr%p%approx_thickness_lw +end subroutine f90wrap_struc_data_type__get__approx_thickness_lw + +subroutine f90wrap_struc_data_type__set__approx_thickness_lw(this, f90wrap_approx_thickness_lw) + use artemis__misc_types, only: struc_data_type + implicit none + type struc_data_type_ptr_type + type(struc_data_type), pointer :: p => NULL() + end type struc_data_type_ptr_type + integer, intent(in) :: this(2) + type(struc_data_type_ptr_type) :: this_ptr + real(4), intent(in) :: f90wrap_approx_thickness_lw + + this_ptr = transfer(this, this_ptr) + this_ptr%p%approx_thickness_lw = f90wrap_approx_thickness_lw +end subroutine f90wrap_struc_data_type__set__approx_thickness_lw + +subroutine f90wrap_struc_data_type__get__approx_thickness_up(this, f90wrap_approx_thickness_up) + use artemis__misc_types, only: struc_data_type + implicit none + type struc_data_type_ptr_type + type(struc_data_type), pointer :: p => NULL() + end type struc_data_type_ptr_type + integer, intent(in) :: this(2) + type(struc_data_type_ptr_type) :: this_ptr + real(4), intent(out) :: f90wrap_approx_thickness_up + + this_ptr = transfer(this, this_ptr) + f90wrap_approx_thickness_up = this_ptr%p%approx_thickness_up +end subroutine f90wrap_struc_data_type__get__approx_thickness_up + +subroutine f90wrap_struc_data_type__set__approx_thickness_up(this, f90wrap_approx_thickness_up) + use artemis__misc_types, only: struc_data_type + implicit none + type struc_data_type_ptr_type + type(struc_data_type), pointer :: p => NULL() + end type struc_data_type_ptr_type + integer, intent(in) :: this(2) + type(struc_data_type_ptr_type) :: this_ptr + real(4), intent(in) :: f90wrap_approx_thickness_up + + this_ptr = transfer(this, this_ptr) + this_ptr%p%approx_thickness_up = f90wrap_approx_thickness_up +end subroutine f90wrap_struc_data_type__set__approx_thickness_up + +subroutine f90wrap_struc_data_type__array__mismatch(this, nd, dtype, dshape, dloc) + use artemis__misc_types, only: struc_data_type + use, intrinsic :: iso_c_binding, only : c_int + implicit none + type struc_data_type_ptr_type + type(struc_data_type), pointer :: p => NULL() + end type struc_data_type_ptr_type + integer(c_int), intent(in) :: this(2) + type(struc_data_type_ptr_type) :: this_ptr + integer(c_int), intent(out) :: nd + integer(c_int), intent(out) :: dtype + integer(c_int), dimension(10), intent(out) :: dshape + integer*8, intent(out) :: dloc + + nd = 1 + dtype = 11 + this_ptr = transfer(this, this_ptr) + dshape(1:1) = shape(this_ptr%p%mismatch) + dloc = loc(this_ptr%p%mismatch) +end subroutine f90wrap_struc_data_type__array__mismatch + +subroutine f90wrap_struc_data_type__array__shift(this, nd, dtype, dshape, dloc) + use artemis__misc_types, only: struc_data_type + use, intrinsic :: iso_c_binding, only : c_int + implicit none + type struc_data_type_ptr_type + type(struc_data_type), pointer :: p => NULL() + end type struc_data_type_ptr_type + integer(c_int), intent(in) :: this(2) + type(struc_data_type_ptr_type) :: this_ptr + integer(c_int), intent(out) :: nd + integer(c_int), intent(out) :: dtype + integer(c_int), dimension(10), intent(out) :: dshape + integer*8, intent(out) :: dloc + + nd = 1 + dtype = 11 + this_ptr = transfer(this, this_ptr) + dshape(1:1) = shape(this_ptr%p%shift) + dloc = loc(this_ptr%p%shift) +end subroutine f90wrap_struc_data_type__array__shift + +subroutine f90wrap_struc_data_type__get__swap_density(this, f90wrap_swap_density) + use artemis__misc_types, only: struc_data_type + implicit none + type struc_data_type_ptr_type + type(struc_data_type), pointer :: p => NULL() + end type struc_data_type_ptr_type + integer, intent(in) :: this(2) + type(struc_data_type_ptr_type) :: this_ptr + real(4), intent(out) :: f90wrap_swap_density + + this_ptr = transfer(this, this_ptr) + f90wrap_swap_density = this_ptr%p%swap_density +end subroutine f90wrap_struc_data_type__get__swap_density + +subroutine f90wrap_struc_data_type__set__swap_density(this, f90wrap_swap_density) + use artemis__misc_types, only: struc_data_type + implicit none + type struc_data_type_ptr_type + type(struc_data_type), pointer :: p => NULL() + end type struc_data_type_ptr_type + integer, intent(in) :: this(2) + type(struc_data_type_ptr_type) :: this_ptr + real(4), intent(in) :: f90wrap_swap_density + + this_ptr = transfer(this, this_ptr) + this_ptr%p%swap_density = f90wrap_swap_density +end subroutine f90wrap_struc_data_type__set__swap_density + +subroutine f90wrap_struc_data_type__array__approx_eff_swap_conc(this, nd, dtype, dshape, dloc) + use artemis__misc_types, only: struc_data_type + use, intrinsic :: iso_c_binding, only : c_int + implicit none + type struc_data_type_ptr_type + type(struc_data_type), pointer :: p => NULL() + end type struc_data_type_ptr_type + integer(c_int), intent(in) :: this(2) + type(struc_data_type_ptr_type) :: this_ptr + integer(c_int), intent(out) :: nd + integer(c_int), intent(out) :: dtype + integer(c_int), dimension(10), intent(out) :: dshape + integer*8, intent(out) :: dloc + + nd = 1 + dtype = 11 + this_ptr = transfer(this, this_ptr) + dshape(1:1) = shape(this_ptr%p%approx_eff_swap_conc) + dloc = loc(this_ptr%p%approx_eff_swap_conc) +end subroutine f90wrap_struc_data_type__array__approx_eff_swap_conc + +subroutine f90wrap_misc_types__struc_data_type_initialise(this) + use artemis__misc_types, only: struc_data_type + implicit none + + type struc_data_type_ptr_type + type(struc_data_type), pointer :: p => NULL() + end type struc_data_type_ptr_type + type(struc_data_type_ptr_type) :: this_ptr + integer, intent(out), dimension(2) :: this + allocate(this_ptr%p) + this = transfer(this_ptr, this) +end subroutine f90wrap_misc_types__struc_data_type_initialise + +subroutine f90wrap_misc_types__struc_data_type_finalise(this) + use artemis__misc_types, only: struc_data_type + implicit none + + type struc_data_type_ptr_type + type(struc_data_type), pointer :: p => NULL() + end type struc_data_type_ptr_type + type(struc_data_type_ptr_type) :: this_ptr + integer, intent(in), dimension(2) :: this + this_ptr = transfer(this, this_ptr) + deallocate(this_ptr%p) +end subroutine f90wrap_misc_types__struc_data_type_finalise + +! End of module artemis__misc_types defined in file ../fortran/lib/mod_misc_types.f90 + diff --git a/tests/cell_edits_identify_terminations_CaZrO3/DCHECK/POSCAR_term1 b/test/cell_edits_identify_terminations_CaZrO3/DCHECK/POSCAR_term1 similarity index 100% rename from tests/cell_edits_identify_terminations_CaZrO3/DCHECK/POSCAR_term1 rename to test/cell_edits_identify_terminations_CaZrO3/DCHECK/POSCAR_term1 diff --git a/tests/cell_edits_identify_terminations_CaZrO3/DCHECK/POSCAR_term2 b/test/cell_edits_identify_terminations_CaZrO3/DCHECK/POSCAR_term2 similarity index 100% rename from tests/cell_edits_identify_terminations_CaZrO3/DCHECK/POSCAR_term2 rename to test/cell_edits_identify_terminations_CaZrO3/DCHECK/POSCAR_term2 diff --git a/tests/cell_edits_identify_terminations_CaZrO3/POSCAR b/test/cell_edits_identify_terminations_CaZrO3/POSCAR similarity index 100% rename from tests/cell_edits_identify_terminations_CaZrO3/POSCAR rename to test/cell_edits_identify_terminations_CaZrO3/POSCAR diff --git a/tests/cell_edits_identify_terminations_CaZrO3/param.in b/test/cell_edits_identify_terminations_CaZrO3/param.in similarity index 97% rename from tests/cell_edits_identify_terminations_CaZrO3/param.in rename to test/cell_edits_identify_terminations_CaZrO3/param.in index 6b36416..35b7332 100644 --- a/tests/cell_edits_identify_terminations_CaZrO3/param.in +++ b/test/cell_edits_identify_terminations_CaZrO3/param.in @@ -12,9 +12,10 @@ END SETTINGS CELL_EDITS LSURF_GEN = T - MILLER_PLANE = 0 1 0 + MILLER_PLANE = 0 0 1 SLAB_THICKNESS = 5 VACUUM = 20 + USE_PRICEL = T END CELL_EDITS diff --git a/tests/cell_edits_identify_terminations_TMDC-H/DCHECK/POSCAR_term1 b/test/cell_edits_identify_terminations_TMDC-H/DCHECK/POSCAR_term1 similarity index 100% rename from tests/cell_edits_identify_terminations_TMDC-H/DCHECK/POSCAR_term1 rename to test/cell_edits_identify_terminations_TMDC-H/DCHECK/POSCAR_term1 diff --git a/tests/cell_edits_identify_terminations_TMDC-H/POSCAR b/test/cell_edits_identify_terminations_TMDC-H/POSCAR similarity index 100% rename from tests/cell_edits_identify_terminations_TMDC-H/POSCAR rename to test/cell_edits_identify_terminations_TMDC-H/POSCAR diff --git a/tests/cell_edits_identify_terminations_TMDC-H/param.in b/test/cell_edits_identify_terminations_TMDC-H/param.in similarity index 100% rename from tests/cell_edits_identify_terminations_TMDC-H/param.in rename to test/cell_edits_identify_terminations_TMDC-H/param.in diff --git a/tests/cell_edits_identify_terminations_TMDC-T/DCHECK/POSCAR_term1 b/test/cell_edits_identify_terminations_TMDC-T/DCHECK/POSCAR_term1 similarity index 100% rename from tests/cell_edits_identify_terminations_TMDC-T/DCHECK/POSCAR_term1 rename to test/cell_edits_identify_terminations_TMDC-T/DCHECK/POSCAR_term1 diff --git a/tests/cell_edits_identify_terminations_TMDC-T/POSCAR b/test/cell_edits_identify_terminations_TMDC-T/POSCAR similarity index 100% rename from tests/cell_edits_identify_terminations_TMDC-T/POSCAR rename to test/cell_edits_identify_terminations_TMDC-T/POSCAR diff --git a/tests/cell_edits_identify_terminations_TMDC-T/param.in b/test/cell_edits_identify_terminations_TMDC-T/param.in similarity index 100% rename from tests/cell_edits_identify_terminations_TMDC-T/param.in rename to test/cell_edits_identify_terminations_TMDC-T/param.in diff --git a/test/cell_edits_identify_terminations_graphene/DCHECK/POSCAR_term1 b/test/cell_edits_identify_terminations_graphene/DCHECK/POSCAR_term1 new file mode 100644 index 0000000..a0e52bf --- /dev/null +++ b/test/cell_edits_identify_terminations_graphene/DCHECK/POSCAR_term1 @@ -0,0 +1,13 @@ +C2 + 1.000000000 + 2.467291117 0.000000000 0.000000000 + 0.000000000 10.000000954 0.000000000 + -0.000000108 0.000000000 18.273471832 +C +5 +Direct + 0.996864974 0.249999985 0.000733164 + 0.496864915 0.249999985 0.117664248 + 0.996864915 0.249999985 0.234595314 + 0.496864945 0.249999985 0.039710194 + 0.996864796 0.249999985 0.156641290 diff --git a/test/cell_edits_identify_terminations_graphene/POSCAR b/test/cell_edits_identify_terminations_graphene/POSCAR new file mode 100644 index 0000000..a6619dc --- /dev/null +++ b/test/cell_edits_identify_terminations_graphene/POSCAR @@ -0,0 +1,10 @@ +C2 +1.0 + 1.2336456308015411 -2.1367369110836258 0.0000000000000000 + 1.2336456308015411 2.1367369110836258 0.0000000000000000 + 0.0000000000000000 0.0000000000000000 10.0 +C +2 +direct + 0.0000000000000000 0.0000000000000000 0.2500000000000000 C0+ + 0.3333333333333330 0.6666666666666661 0.2500000000000000 C0+ diff --git a/test/cell_edits_identify_terminations_graphene/param.in b/test/cell_edits_identify_terminations_graphene/param.in new file mode 100644 index 0000000..89ddaba --- /dev/null +++ b/test/cell_edits_identify_terminations_graphene/param.in @@ -0,0 +1,18 @@ +SETTINGS + TASK = 0 + RESTART = 0 + STRUC1_FILE = POSCAR ! lower structure/interface structure +! STRUC2_FILE = ! upper structure (not used if RESTART > 0) + MASTER_DIR = DINTERFACES + SUBDIR_PREFIX = D + IPRINT = 0 + CLOCK = ! taken from the time clock by default +END SETTINGS + + +CELL_EDITS + LSURF_GEN = T + MILLER_PLANE = 1 0 0 + NUM_LAYERS = 5 + LAYER_SEP = 0.1 +END CELL_EDITS diff --git a/tests/generate_interface/DCHECK/D01/DSHIFT/D01/DSWAP/D01/POSCAR b/test/generate_interface/DCHECK/D01/DSHIFT/D01/DSWAP/D01/POSCAR similarity index 100% rename from tests/generate_interface/DCHECK/D01/DSHIFT/D01/DSWAP/D01/POSCAR rename to test/generate_interface/DCHECK/D01/DSHIFT/D01/DSWAP/D01/POSCAR diff --git a/tests/generate_interface/DCHECK/D01/DSHIFT/D01/DSWAP/D02/POSCAR b/test/generate_interface/DCHECK/D01/DSHIFT/D01/DSWAP/D02/POSCAR similarity index 100% rename from tests/generate_interface/DCHECK/D01/DSHIFT/D01/DSWAP/D02/POSCAR rename to test/generate_interface/DCHECK/D01/DSHIFT/D01/DSWAP/D02/POSCAR diff --git a/tests/generate_interface/DCHECK/D01/DSHIFT/D01/DSWAP/D03/POSCAR b/test/generate_interface/DCHECK/D01/DSHIFT/D01/DSWAP/D03/POSCAR similarity index 100% rename from tests/generate_interface/DCHECK/D01/DSHIFT/D01/DSWAP/D03/POSCAR rename to test/generate_interface/DCHECK/D01/DSHIFT/D01/DSWAP/D03/POSCAR diff --git a/tests/generate_interface/DCHECK/D01/DSHIFT/D01/DSWAP/D04/POSCAR b/test/generate_interface/DCHECK/D01/DSHIFT/D01/DSWAP/D04/POSCAR similarity index 100% rename from tests/generate_interface/DCHECK/D01/DSHIFT/D01/DSWAP/D04/POSCAR rename to test/generate_interface/DCHECK/D01/DSHIFT/D01/DSWAP/D04/POSCAR diff --git a/tests/generate_interface/DCHECK/D01/DSHIFT/D01/DSWAP/D05/POSCAR b/test/generate_interface/DCHECK/D01/DSHIFT/D01/DSWAP/D05/POSCAR similarity index 100% rename from tests/generate_interface/DCHECK/D01/DSHIFT/D01/DSWAP/D05/POSCAR rename to test/generate_interface/DCHECK/D01/DSHIFT/D01/DSWAP/D05/POSCAR diff --git a/tests/generate_interface/DCHECK/D01/DSHIFT/D01/POSCAR b/test/generate_interface/DCHECK/D01/DSHIFT/D01/POSCAR similarity index 100% rename from tests/generate_interface/DCHECK/D01/DSHIFT/D01/POSCAR rename to test/generate_interface/DCHECK/D01/DSHIFT/D01/POSCAR diff --git a/tests/generate_interface/DCHECK/D01/DSHIFT/D02/DSWAP/D01/POSCAR b/test/generate_interface/DCHECK/D01/DSHIFT/D02/DSWAP/D01/POSCAR similarity index 100% rename from tests/generate_interface/DCHECK/D01/DSHIFT/D02/DSWAP/D01/POSCAR rename to test/generate_interface/DCHECK/D01/DSHIFT/D02/DSWAP/D01/POSCAR diff --git a/tests/generate_interface/DCHECK/D01/DSHIFT/D02/DSWAP/D02/POSCAR b/test/generate_interface/DCHECK/D01/DSHIFT/D02/DSWAP/D02/POSCAR similarity index 100% rename from tests/generate_interface/DCHECK/D01/DSHIFT/D02/DSWAP/D02/POSCAR rename to test/generate_interface/DCHECK/D01/DSHIFT/D02/DSWAP/D02/POSCAR diff --git a/tests/generate_interface/DCHECK/D01/DSHIFT/D02/DSWAP/D03/POSCAR b/test/generate_interface/DCHECK/D01/DSHIFT/D02/DSWAP/D03/POSCAR similarity index 100% rename from tests/generate_interface/DCHECK/D01/DSHIFT/D02/DSWAP/D03/POSCAR rename to test/generate_interface/DCHECK/D01/DSHIFT/D02/DSWAP/D03/POSCAR diff --git a/tests/generate_interface/DCHECK/D01/DSHIFT/D02/DSWAP/D04/POSCAR b/test/generate_interface/DCHECK/D01/DSHIFT/D02/DSWAP/D04/POSCAR similarity index 100% rename from tests/generate_interface/DCHECK/D01/DSHIFT/D02/DSWAP/D04/POSCAR rename to test/generate_interface/DCHECK/D01/DSHIFT/D02/DSWAP/D04/POSCAR diff --git a/tests/generate_interface/DCHECK/D01/DSHIFT/D02/DSWAP/D05/POSCAR b/test/generate_interface/DCHECK/D01/DSHIFT/D02/DSWAP/D05/POSCAR similarity index 100% rename from tests/generate_interface/DCHECK/D01/DSHIFT/D02/DSWAP/D05/POSCAR rename to test/generate_interface/DCHECK/D01/DSHIFT/D02/DSWAP/D05/POSCAR diff --git a/tests/generate_interface/DCHECK/D01/DSHIFT/D02/POSCAR b/test/generate_interface/DCHECK/D01/DSHIFT/D02/POSCAR similarity index 100% rename from tests/generate_interface/DCHECK/D01/DSHIFT/D02/POSCAR rename to test/generate_interface/DCHECK/D01/DSHIFT/D02/POSCAR diff --git a/tests/generate_interface/DCHECK/D01/DSHIFT/D03/DSWAP/D01/POSCAR b/test/generate_interface/DCHECK/D01/DSHIFT/D03/DSWAP/D01/POSCAR similarity index 100% rename from tests/generate_interface/DCHECK/D01/DSHIFT/D03/DSWAP/D01/POSCAR rename to test/generate_interface/DCHECK/D01/DSHIFT/D03/DSWAP/D01/POSCAR diff --git a/tests/generate_interface/DCHECK/D01/DSHIFT/D03/DSWAP/D02/POSCAR b/test/generate_interface/DCHECK/D01/DSHIFT/D03/DSWAP/D02/POSCAR similarity index 100% rename from tests/generate_interface/DCHECK/D01/DSHIFT/D03/DSWAP/D02/POSCAR rename to test/generate_interface/DCHECK/D01/DSHIFT/D03/DSWAP/D02/POSCAR diff --git a/tests/generate_interface/DCHECK/D01/DSHIFT/D03/DSWAP/D03/POSCAR b/test/generate_interface/DCHECK/D01/DSHIFT/D03/DSWAP/D03/POSCAR similarity index 100% rename from tests/generate_interface/DCHECK/D01/DSHIFT/D03/DSWAP/D03/POSCAR rename to test/generate_interface/DCHECK/D01/DSHIFT/D03/DSWAP/D03/POSCAR diff --git a/tests/generate_interface/DCHECK/D01/DSHIFT/D03/DSWAP/D04/POSCAR b/test/generate_interface/DCHECK/D01/DSHIFT/D03/DSWAP/D04/POSCAR similarity index 100% rename from tests/generate_interface/DCHECK/D01/DSHIFT/D03/DSWAP/D04/POSCAR rename to test/generate_interface/DCHECK/D01/DSHIFT/D03/DSWAP/D04/POSCAR diff --git a/tests/generate_interface/DCHECK/D01/DSHIFT/D03/DSWAP/D05/POSCAR b/test/generate_interface/DCHECK/D01/DSHIFT/D03/DSWAP/D05/POSCAR similarity index 100% rename from tests/generate_interface/DCHECK/D01/DSHIFT/D03/DSWAP/D05/POSCAR rename to test/generate_interface/DCHECK/D01/DSHIFT/D03/DSWAP/D05/POSCAR diff --git a/tests/generate_interface/DCHECK/D01/DSHIFT/D03/POSCAR b/test/generate_interface/DCHECK/D01/DSHIFT/D03/POSCAR similarity index 100% rename from tests/generate_interface/DCHECK/D01/DSHIFT/D03/POSCAR rename to test/generate_interface/DCHECK/D01/DSHIFT/D03/POSCAR diff --git a/tests/generate_interface/DCHECK/D01/DSHIFT/D04/DSWAP/D01/POSCAR b/test/generate_interface/DCHECK/D01/DSHIFT/D04/DSWAP/D01/POSCAR similarity index 100% rename from tests/generate_interface/DCHECK/D01/DSHIFT/D04/DSWAP/D01/POSCAR rename to test/generate_interface/DCHECK/D01/DSHIFT/D04/DSWAP/D01/POSCAR diff --git a/tests/generate_interface/DCHECK/D01/DSHIFT/D04/DSWAP/D02/POSCAR b/test/generate_interface/DCHECK/D01/DSHIFT/D04/DSWAP/D02/POSCAR similarity index 100% rename from tests/generate_interface/DCHECK/D01/DSHIFT/D04/DSWAP/D02/POSCAR rename to test/generate_interface/DCHECK/D01/DSHIFT/D04/DSWAP/D02/POSCAR diff --git a/tests/generate_interface/DCHECK/D01/DSHIFT/D04/DSWAP/D03/POSCAR b/test/generate_interface/DCHECK/D01/DSHIFT/D04/DSWAP/D03/POSCAR similarity index 100% rename from tests/generate_interface/DCHECK/D01/DSHIFT/D04/DSWAP/D03/POSCAR rename to test/generate_interface/DCHECK/D01/DSHIFT/D04/DSWAP/D03/POSCAR diff --git a/tests/generate_interface/DCHECK/D01/DSHIFT/D04/DSWAP/D04/POSCAR b/test/generate_interface/DCHECK/D01/DSHIFT/D04/DSWAP/D04/POSCAR similarity index 100% rename from tests/generate_interface/DCHECK/D01/DSHIFT/D04/DSWAP/D04/POSCAR rename to test/generate_interface/DCHECK/D01/DSHIFT/D04/DSWAP/D04/POSCAR diff --git a/tests/generate_interface/DCHECK/D01/DSHIFT/D04/DSWAP/D05/POSCAR b/test/generate_interface/DCHECK/D01/DSHIFT/D04/DSWAP/D05/POSCAR similarity index 100% rename from tests/generate_interface/DCHECK/D01/DSHIFT/D04/DSWAP/D05/POSCAR rename to test/generate_interface/DCHECK/D01/DSHIFT/D04/DSWAP/D05/POSCAR diff --git a/tests/generate_interface/DCHECK/D01/DSHIFT/D04/POSCAR b/test/generate_interface/DCHECK/D01/DSHIFT/D04/POSCAR similarity index 100% rename from tests/generate_interface/DCHECK/D01/DSHIFT/D04/POSCAR rename to test/generate_interface/DCHECK/D01/DSHIFT/D04/POSCAR diff --git a/tests/generate_interface/DCHECK/D01/DSHIFT/D05/POSCAR b/test/generate_interface/DCHECK/D01/DSHIFT/D05/POSCAR similarity index 100% rename from tests/generate_interface/DCHECK/D01/DSHIFT/D05/POSCAR rename to test/generate_interface/DCHECK/D01/DSHIFT/D05/POSCAR diff --git a/test/generate_interface/DCHECK/D01/DSHIFT/shift_vals.txt b/test/generate_interface/DCHECK/D01/DSHIFT/shift_vals.txt new file mode 100644 index 0000000..e69de29 diff --git a/tests/generate_interface/DCHECK/settings.txt b/test/generate_interface/DCHECK/settings.txt similarity index 100% rename from tests/generate_interface/DCHECK/settings.txt rename to test/generate_interface/DCHECK/settings.txt diff --git a/tests/generate_interface/POSCAR_Ge b/test/generate_interface/POSCAR_Ge similarity index 100% rename from tests/generate_interface/POSCAR_Ge rename to test/generate_interface/POSCAR_Ge diff --git a/tests/generate_interface/POSCAR_Si b/test/generate_interface/POSCAR_Si similarity index 100% rename from tests/generate_interface/POSCAR_Si rename to test/generate_interface/POSCAR_Si diff --git a/examples/generate_interface/param.in b/test/generate_interface/param.in similarity index 100% rename from examples/generate_interface/param.in rename to test/generate_interface/param.in diff --git a/tests/identify_terminations/DCHECK/DLW_TERMS/POSCAR_term1 b/test/identify_terminations/DCHECK/DLW_TERMS/POSCAR_term1 similarity index 100% rename from tests/identify_terminations/DCHECK/DLW_TERMS/POSCAR_term1 rename to test/identify_terminations/DCHECK/DLW_TERMS/POSCAR_term1 diff --git a/tests/identify_terminations/POSCAR b/test/identify_terminations/POSCAR similarity index 100% rename from tests/identify_terminations/POSCAR rename to test/identify_terminations/POSCAR diff --git a/tests/identify_terminations/param.in b/test/identify_terminations/param.in similarity index 100% rename from tests/identify_terminations/param.in rename to test/identify_terminations/param.in diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D01/DSWAP/D01/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D01/DSWAP/D01/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D01/DSWAP/D01/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D01/DSWAP/D01/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D01/DSWAP/D02/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D01/DSWAP/D02/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D01/DSWAP/D02/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D01/DSWAP/D02/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D01/DSWAP/D03/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D01/DSWAP/D03/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D01/DSWAP/D03/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D01/DSWAP/D03/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D01/DSWAP/D04/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D01/DSWAP/D04/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D01/DSWAP/D04/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D01/DSWAP/D04/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D01/DSWAP/D05/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D01/DSWAP/D05/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D01/DSWAP/D05/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D01/DSWAP/D05/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D01/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D01/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D01/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D01/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D02/DSWAP/D01/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D02/DSWAP/D01/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D02/DSWAP/D01/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D02/DSWAP/D01/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D02/DSWAP/D02/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D02/DSWAP/D02/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D02/DSWAP/D02/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D02/DSWAP/D02/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D02/DSWAP/D03/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D02/DSWAP/D03/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D02/DSWAP/D03/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D02/DSWAP/D03/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D02/DSWAP/D04/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D02/DSWAP/D04/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D02/DSWAP/D04/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D02/DSWAP/D04/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D02/DSWAP/D05/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D02/DSWAP/D05/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D02/DSWAP/D05/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D02/DSWAP/D05/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D02/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D02/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D02/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D02/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D03/DSWAP/D01/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D03/DSWAP/D01/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D03/DSWAP/D01/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D03/DSWAP/D01/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D03/DSWAP/D02/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D03/DSWAP/D02/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D03/DSWAP/D02/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D03/DSWAP/D02/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D03/DSWAP/D03/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D03/DSWAP/D03/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D03/DSWAP/D03/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D03/DSWAP/D03/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D03/DSWAP/D04/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D03/DSWAP/D04/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D03/DSWAP/D04/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D03/DSWAP/D04/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D03/DSWAP/D05/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D03/DSWAP/D05/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D03/DSWAP/D05/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D03/DSWAP/D05/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D03/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D03/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D03/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D03/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D04/DSWAP/D01/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D04/DSWAP/D01/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D04/DSWAP/D01/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D04/DSWAP/D01/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D04/DSWAP/D02/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D04/DSWAP/D02/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D04/DSWAP/D02/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D04/DSWAP/D02/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D04/DSWAP/D03/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D04/DSWAP/D03/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D04/DSWAP/D03/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D04/DSWAP/D03/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D04/DSWAP/D04/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D04/DSWAP/D04/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D04/DSWAP/D04/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D04/DSWAP/D04/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D04/DSWAP/D05/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D04/DSWAP/D05/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D04/DSWAP/D05/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D04/DSWAP/D05/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D04/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D04/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D04/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D04/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D05/DSWAP/D01/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D05/DSWAP/D01/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D05/DSWAP/D01/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D05/DSWAP/D01/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D05/DSWAP/D02/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D05/DSWAP/D02/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D05/DSWAP/D02/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D05/DSWAP/D02/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D05/DSWAP/D03/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D05/DSWAP/D03/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D05/DSWAP/D03/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D05/DSWAP/D03/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D05/DSWAP/D04/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D05/DSWAP/D04/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D05/DSWAP/D04/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D05/DSWAP/D04/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D05/DSWAP/D05/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D05/DSWAP/D05/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D05/DSWAP/D05/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D05/DSWAP/D05/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/D05/POSCAR b/test/pregenerated_interface/DCHECK/DSHIFT/D05/POSCAR similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/D05/POSCAR rename to test/pregenerated_interface/DCHECK/DSHIFT/D05/POSCAR diff --git a/tests/pregenerated_interface/DCHECK/DSHIFT/shift_vals.txt b/test/pregenerated_interface/DCHECK/DSHIFT/shift_vals.txt similarity index 100% rename from tests/pregenerated_interface/DCHECK/DSHIFT/shift_vals.txt rename to test/pregenerated_interface/DCHECK/DSHIFT/shift_vals.txt diff --git a/tests/pregenerated_interface/DCHECK/interface_location.dat b/test/pregenerated_interface/DCHECK/interface_location.dat similarity index 100% rename from tests/pregenerated_interface/DCHECK/interface_location.dat rename to test/pregenerated_interface/DCHECK/interface_location.dat diff --git a/tests/pregenerated_interface/DCHECK/settings.txt b/test/pregenerated_interface/DCHECK/settings.txt similarity index 100% rename from tests/pregenerated_interface/DCHECK/settings.txt rename to test/pregenerated_interface/DCHECK/settings.txt diff --git a/tests/pregenerated_interface/POSCAR b/test/pregenerated_interface/POSCAR similarity index 100% rename from tests/pregenerated_interface/POSCAR rename to test/pregenerated_interface/POSCAR diff --git a/tests/pregenerated_interface/param.in b/test/pregenerated_interface/param.in similarity index 100% rename from tests/pregenerated_interface/param.in rename to test/pregenerated_interface/param.in diff --git a/tests/tester.sh b/test/tester.sh similarity index 100% rename from tests/tester.sh rename to test/tester.sh diff --git a/tests/tol_sym_thickness/DCHECK/POSCAR_term1 b/test/tol_sym_thickness/DCHECK/POSCAR_term1 similarity index 100% rename from tests/tol_sym_thickness/DCHECK/POSCAR_term1 rename to test/tol_sym_thickness/DCHECK/POSCAR_term1 diff --git a/test/tol_sym_thickness/DTERMINATIONS/POSCAR_term1 b/test/tol_sym_thickness/DTERMINATIONS/POSCAR_term1 new file mode 100644 index 0000000..f3a2970 --- /dev/null +++ b/test/tol_sym_thickness/DTERMINATIONS/POSCAR_term1 @@ -0,0 +1,32 @@ +TiO2 Anastase + 1.000000000 + 3.935910463 0.000000000 0.000000000 + 0.000000000 3.935910463 0.000000000 + 0.000000000 0.000000000 31.978628640 +Ti O +8 16 +Direct + 0.000000000 0.000000000 0.472611422 + 0.500000000 0.500000000 0.012960099 + 0.000000000 0.000000000 0.166177207 + 0.500000000 0.500000000 0.319394314 + 0.000000000 0.500000000 0.549234880 + 0.500000000 0.000000000 0.089583557 + 0.000000000 0.500000000 0.242800665 + 0.500000000 0.000000000 0.396017772 + 0.000000000 0.000000000 0.536242516 + 0.500000000 0.500000000 0.076591193 + 0.000000000 0.000000000 0.229808301 + 0.500000000 0.500000000 0.383025408 + 0.000000000 0.500000000 0.000000000 + 0.500000000 0.000000000 0.153217108 + 0.000000000 0.500000000 0.306434215 + 0.500000000 0.000000000 0.459651323 + 0.000000000 0.500000000 0.485616880 + 0.500000000 0.000000000 0.025965557 + 0.000000000 0.500000000 0.179182664 + 0.500000000 0.000000000 0.332399772 + 0.500000000 0.500000000 0.562207618 + 0.000000000 0.000000000 0.102556295 + 0.500000000 0.500000000 0.255773403 + 0.000000000 0.000000000 0.408990511 diff --git a/tests/tol_sym_thickness/POSCAR b/test/tol_sym_thickness/POSCAR similarity index 100% rename from tests/tol_sym_thickness/POSCAR rename to test/tol_sym_thickness/POSCAR diff --git a/tests/tol_sym_thickness/param.in b/test/tol_sym_thickness/param.in similarity index 100% rename from tests/tol_sym_thickness/param.in rename to test/tol_sym_thickness/param.in diff --git a/tools/compress.sh b/tools/compress.sh deleted file mode 100755 index 3caaf71..0000000 --- a/tools/compress.sh +++ /dev/null @@ -1,35 +0,0 @@ -#!/bin/bash -#executing this tars up the code directory. - -OS=$(uname) -case "$OS" in - "Darwin") - echo "OS: Darwin, MacOS" - scriptdir="$(pwd "$(dirname "${BASH_SOURCE[0]}")")/" - codedir=$(sed 's|tools/||' <<<"$scriptdir") - tarname=$(sed 's|/$||;s|.*/D||' <<<"$codedir")".tar.gz" - ;; - "Linux") - echo "OS: Linux" - scriptdir="$(readlink -f "$(dirname "${BASH_SOURCE[0]}")")/" - codedir=$(sed 's|tools/||' <<<"$scriptdir") - tarname=$(sed 's|/$||;s|.*/D\?||' <<<"$codedir")".tar.gz" - ;; - *) - echo "Operating system ($OS) could not be defined" - exit 1 -esac - -#scriptdir="$(readlink -f "$(dirname "${BASH_SOURCE[0]}")")/" -#codedir=$(sed 's|tools/||' <<<"$scriptdir") -codeend=$(sed 's|/.*/\(.*\)/|\1|' <<<"$codedir") -tardir=$(sed 's|/$||;s|\(.*/\).*|\1|' <<<"$codedir") -tarpath="$tardir$tarname" - -#cd $codedir - -#echo "tar -czvf $tarpath -C $tardir $codeend" -#tar --exclude-backups -czvf $tarpath -C $tardir $codeend #$scriptdir -tar --exclude="*#" --exclude="*.#*" --exclude="*~" --exclude="TODO" --exclude="OLD_*" --exclude="*.aux" --exclude="*.log" --exclude="*.out" --exclude="*.toc" --exclude="*.txt" --exclude="${codeend}/bin" --exclude="*.tar.gz" --exclude="${codeend}/src/archive" --exclude="${codeend}/obj" --exclude="${codeend}/.git" --exclude="*.gitignore" -czvf $tarpath -C $tardir $codeend -mv $tarpath ../. -echo "made tar file $tarname" diff --git a/tools/version_number.py b/tools/version_number.py new file mode 100644 index 0000000..6f308ad --- /dev/null +++ b/tools/version_number.py @@ -0,0 +1,28 @@ +import re + +def update_version(new_version): + # Update fpm.toml + with open('fpm.toml', 'r') as file: + content = file.read() + content = re.sub(r'version = "\d+\.\d+\.\d+.*"', f'version = "{new_version}"', content) + with open('fpm.toml', 'w') as file: + file.write(content) + + # Update Fortran module + with open('src/fortran/lib/mod_io_utils.F90', 'r') as file: + content = file.read() + content = re.sub(r'character\(len=\*\), parameter :: artemis__version__ = "\d+\.\d+\.\d+.*"', f'character(len=*), parameter :: artemis__version__ = "{new_version}"', content) + with open('src/fortran/lib/mod_io_utils.F90', 'w') as file: + file.write(content) + +def get_version(): + # get the version number from fpm.toml + with open('fpm.toml', 'r') as file: + content = file.read() + match = re.search(r'version = "(\d+\.\d+\.\d+.*)"', content) + print(match.group(1)) + if match: + return match.group(1) + +if __name__ == '__main__': + update_version(get_version())