From 6712de2ad9b5636ba9c5ef0e0af61966880426f7 Mon Sep 17 00:00:00 2001 From: Paul Romano Date: Thu, 21 Feb 2019 15:49:58 -0600 Subject: [PATCH] Remove remaining Fortran source files --- CMakeLists.txt | 170 +---- include/openmc/capi.h | 8 - include/openmc/cell.h | 6 +- openmc/capi/core.py | 3 +- src/bank_header.F90 | 73 -- src/constants.F90 | 166 ----- src/dict_header.F90 | 541 -------------- src/error.F90 | 258 ------- src/error.cpp | 24 + src/geometry.F90 | 73 -- src/hdf5_interface.F90 | 1445 ------------------------------------- src/initialize.F90 | 44 -- src/initialize.cpp | 16 +- src/material_header.F90 | 48 -- src/message_passing.F90 | 13 - src/message_passing.cpp | 20 +- src/particle_header.F90 | 150 ---- src/pugixml/pugixml_c.cpp | 1 - src/pugixml/pugixml_c.hpp | 97 --- src/pugixml/pugixml_f.F90 | 451 ------------ src/random_lcg.F90 | 26 - src/settings.F90 | 40 - src/simulation_header.F90 | 88 --- src/stl_vector.F90 | 550 -------------- src/string.F90 | 355 --------- src/vector_header.F90 | 113 --- src/xml_interface.F90 | 367 ---------- 27 files changed, 37 insertions(+), 5109 deletions(-) delete mode 100644 src/bank_header.F90 delete mode 100644 src/constants.F90 delete mode 100644 src/dict_header.F90 delete mode 100644 src/error.F90 delete mode 100644 src/geometry.F90 delete mode 100644 src/hdf5_interface.F90 delete mode 100644 src/initialize.F90 delete mode 100644 src/material_header.F90 delete mode 100644 src/message_passing.F90 delete mode 100644 src/particle_header.F90 delete mode 100644 src/pugixml/pugixml_c.cpp delete mode 100644 src/pugixml/pugixml_c.hpp delete mode 100644 src/pugixml/pugixml_f.F90 delete mode 100644 src/random_lcg.F90 delete mode 100644 src/settings.F90 delete mode 100644 src/simulation_header.F90 delete mode 100644 src/stl_vector.F90 delete mode 100644 src/string.F90 delete mode 100644 src/vector_header.F90 delete mode 100644 src/xml_interface.F90 diff --git a/CMakeLists.txt b/CMakeLists.txt index 75dafa848f..93430c6a4e 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -1,5 +1,5 @@ cmake_minimum_required(VERSION 3.3 FATAL_ERROR) -project(openmc Fortran C CXX) +project(openmc C CXX) # Setup output directories set(CMAKE_ARCHIVE_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/lib) @@ -28,16 +28,11 @@ set(maxcoord 10 CACHE STRING "Maximum number of nested coordinate levels") #=============================================================================== set(MPI_ENABLED FALSE) -if($ENV{FC} MATCHES "(mpi[^/]*|ftn)$") - message("-- Detected MPI wrapper: $ENV{FC}") +if($ENV{CXX} MATCHES "(mpi[^/]*|CC)$") + message("-- Detected MPI wrapper: $ENV{CXX}") set(MPI_ENABLED TRUE) endif() -# Check for Fortran 2008 MPI interface -if(MPI_ENABLED AND mpif08) - message("-- Using Fortran 2008 MPI bindings") -endif() - #=============================================================================== # DAGMC Geometry Support - need DAGMC/MOAB #=============================================================================== @@ -97,136 +92,6 @@ endif() set(CMAKE_POSITION_INDEPENDENT_CODE ON) -if(CMAKE_Fortran_COMPILER_ID STREQUAL GNU) - # Make sure version is sufficient - execute_process(COMMAND ${CMAKE_Fortran_COMPILER} -dumpversion - OUTPUT_VARIABLE GCC_VERSION) - if(GCC_VERSION VERSION_LESS 4.9) - message(FATAL_ERROR "gcc version must be 4.9 or higher") - endif() - - # GCC compiler options - list(APPEND f90flags -cpp -std=f2008ts -fbacktrace -O2 -fstack-arrays) - if(debug) - list(REMOVE_ITEM f90flags -O2 -fstack-arrays) - list(APPEND f90flags -g -Wall -Wno-unused-dummy-argument -pedantic - -fbounds-check -ffpe-trap=invalid,overflow,underflow) - list(APPEND ldflags -g) - endif() - if(profile) - list(APPEND f90flags -pg) - list(APPEND ldflags -pg) - endif() - if(optimize) - list(REMOVE_ITEM f90flags -O2) - list(APPEND f90flags -O3) - endif() - if(coverage) - list(APPEND f90flags -coverage) - list(APPEND ldflags -coverage) - endif() - -elseif(CMAKE_Fortran_COMPILER_ID STREQUAL Intel) - # Intel compiler options - list(APPEND f90flags -fpp -std08 -assume byterecl -traceback) - if(debug) - list(APPEND f90flags -g -warn -fp-stack-check - "-check all" -fpe0 -O0) - list(APPEND ldflags -g) - endif() - if(profile) - list(APPEND f90flags -pg) - list(APPEND ldflags -pg) - endif() - if(optimize) - list(APPEND f90flags -O3) - endif() - -elseif(CMAKE_Fortran_COMPILER_ID STREQUAL PGI) - # PGI Fortran compiler options - list(APPEND f90flags -Mpreprocess -Minform=inform -traceback) - add_definitions(-DNO_F2008) - if(debug) - list(APPEND f90flags -g -Mbounds -Mchkptr -Mchkstk) - list(APPEND ldflags -g) - endif() - if(profile) - list(APPEND f90flags -pg) - list(APPEND ldflags -pg) - endif() - if(optimize) - list(APPEND f90flags -fast -Mipa) - endif() - -elseif(CMAKE_Fortran_COMPILER_ID STREQUAL XL) - # IBM XL compiler options - list(APPEND f90flags -O2) - add_definitions(-DNO_F2008) - if(debug) - list(REMOVE_ITEM f90flags -O2) - list(APPEND f90flags -g -C -qflag=i:i -u -O0) - list(APPEND ldflags -g) - endif() - if(profile) - list(APPEND f90flags -p) - list(APPEND ldflags -p) - endif() - if(optimize) - list(REMOVE_ITEM f90flags -O2) - list(APPEND f90flags -O3) - endif() - -elseif(CMAKE_Fortran_COMPILER_ID STREQUAL Cray) - # Cray Fortran compiler options - list(APPEND f90flags -e Z -m 0) - if(debug) - list(APPEND f90flags -g -R abcnsp -O0) - list(APPEND ldflags -g) - endif() - -endif() - -if(CMAKE_C_COMPILER_ID STREQUAL GNU) - # GCC compiler options - list(APPEND cflags -O2) - if(debug) - list(REMOVE_ITEM cflags -O2) - list(APPEND cflags -g -Wall -pedantic -fbounds-check) - endif() - if(profile) - list(APPEND cflags -pg) - endif() - if(optimize) - list(REMOVE_ITEM cflags -O2) - list(APPEND cflags -O3) - endif() - if(coverage) - list(APPEND cflags -coverage) - endif() - -elseif(CMAKE_C_COMPILER_ID STREQUAL Intel) - # Intel compiler options - if(debug) - list(APPEND cflags -g -w3 -ftrapuv -fp-stack-check -O0) - endif() - if(profile) - list(APPEND cflags -pg) - endif() - if(optimize) - list(APPEND cflags -O3) - endif() - -elseif(CMAKE_C_COMPILER_ID MATCHES Clang) - # Clang options - if(debug) - list(APPEND cflags -g -O0 -ftrapv) - endif() - if(optimize) - list(APPEND cflags -O3) - endif() - -endif() - list(APPEND cxxflags -std=c++14 -O2) if(debug) list(REMOVE_ITEM cxxflags -O2) @@ -241,8 +106,6 @@ if(optimize) endif() # Show flags being used -message(STATUS "Fortran flags: ${f90flags}") -message(STATUS "C flags: ${cflags}") message(STATUS "C++ flags: ${cxxflags}") message(STATUS "Linker flags: ${ldflags}") @@ -302,24 +165,6 @@ target_compile_options(faddeeva PRIVATE ${cxxflags}) #=============================================================================== add_library(libopenmc SHARED - src/bank_header.F90 - src/constants.F90 - src/dict_header.F90 - src/error.F90 - src/geometry.F90 - src/hdf5_interface.F90 - src/initialize.F90 - src/material_header.F90 - src/message_passing.F90 - src/particle_header.F90 - src/pugixml/pugixml_f.F90 - src/relaxng - src/settings.F90 - src/simulation_header.F90 - src/stl_vector.F90 - src/string.F90 - src/vector_header.F90 - src/xml_interface.F90 src/bank.cpp src/bremsstrahlung.cpp src/dagmc.cpp @@ -357,7 +202,6 @@ add_library(libopenmc SHARED src/plot.cpp src/position.cpp src/progress_bar.cpp - src/pugixml/pugixml_c.cpp src/urr.cpp src/random_lcg.cpp src/reaction.cpp @@ -415,12 +259,8 @@ target_include_directories(libopenmc PUBLIC include PRIVATE ${HDF5_INCLUDE_DIRS}) -# The libopenmc library has both F90 and C++ so the compile flags must be set -# differently depending on the language. The $ generator -# expression was added in CMake 3.3 -target_compile_options(libopenmc PRIVATE - $<$:${f90flags}> - $<$:${cxxflags}>) +# Set compile flags +target_compile_options(libopenmc PRIVATE ${cxxflags}) target_compile_definitions(libopenmc PRIVATE -DMAX_COORD=${maxcoord}) if (UNIX) diff --git a/include/openmc/capi.h b/include/openmc/capi.h index 695ffa6d12..599daf81c8 100644 --- a/include/openmc/capi.h +++ b/include/openmc/capi.h @@ -164,14 +164,6 @@ extern "C" { // Global variables extern char openmc_err_msg[256]; - extern int32_t n_sab_tables; - extern int32_t n_tallies; - - // Variables that are shared by necessity (can be removed from public header - // later) - extern bool openmc_master; - extern int openmc_n_procs; - extern int openmc_rank; #ifdef __cplusplus } diff --git a/include/openmc/cell.h b/include/openmc/cell.h index e2c3f400af..6343af6057 100644 --- a/include/openmc/cell.h +++ b/include/openmc/cell.h @@ -25,9 +25,9 @@ namespace openmc { //============================================================================== // TODO: Convert to enum -extern "C" int FILL_MATERIAL; -extern "C" int FILL_UNIVERSE; -extern "C" int FILL_LATTICE; +constexpr int FILL_MATERIAL {1}; +constexpr int FILL_UNIVERSE {2}; +constexpr int FILL_LATTICE {3}; // TODO: Convert to enum constexpr int32_t OP_LEFT_PAREN {std::numeric_limits::max()}; diff --git a/openmc/capi/core.py b/openmc/capi/core.py index 540413e7bf..dcca164548 100644 --- a/openmc/capi/core.py +++ b/openmc/capi/core.py @@ -47,6 +47,7 @@ _init_linsolver_argtypes = [_array_1d_int, c_int, _array_1d_int, c_int, c_int, c_double, _array_1d_int, _array_1d_int] _dll.openmc_initialize_linsolver.argtypes = _init_linsolver_argtypes _dll.openmc_initialize_linsolver.restype = None +_dll.openmc_master.restype = c_bool _dll.openmc_next_batch.argtypes = [POINTER(c_int)] _dll.openmc_next_batch.restype = c_int _dll.openmc_next_batch.errcheck = _error_handler @@ -251,7 +252,7 @@ def master(): Whether is master processor or not """ - return c_bool.in_dll(_dll, 'openmc_master').value + return _dll.openmc_master() def next_batch(): diff --git a/src/bank_header.F90 b/src/bank_header.F90 deleted file mode 100644 index 995cc6a3ad..0000000000 --- a/src/bank_header.F90 +++ /dev/null @@ -1,73 +0,0 @@ -module bank_header - - use, intrinsic :: ISO_C_BINDING - - implicit none - -!=============================================================================== -! BANK is used for storing fission sites in eigenvalue calculations. Since all -! the state information of a neutron is not needed, this type allows sites to be -! stored with less memory -!=============================================================================== - - type, bind(C) :: Bank - real(C_DOUBLE) :: wgt ! weight of bank site - real(C_DOUBLE) :: xyz(3) ! location of bank particle - real(C_DOUBLE) :: uvw(3) ! diretional cosines - real(C_DOUBLE) :: E ! energy / energy group if in MG mode. - integer(C_INT) :: delayed_group ! delayed group - integer(C_INT) :: particle ! particle type (neutron, photon, etc.) - end type Bank - - interface - function openmc_fission_bank(ptr, n) result(err) bind(C) - import C_PTR, C_INT64_T, C_INT - type(C_PTR), intent(out) :: ptr - integer(C_INT64_T), intent(out) :: n - integer(C_INT) :: err - end function - - function fission_bank_delayed_group(i) result(g) bind(C) - import C_INT64_T, C_INT - integer(C_INT64_T), value :: i - integer(C_INT) :: g - end function - - function fission_bank_E(i) result(E) bind(C, name='fission_bank_E') - import C_INT64_T, C_DOUBLE - integer(C_INT64_T), value :: i - real(C_DOUBLE) :: E - end function - - function fission_bank_wgt(i) result(wgt) bind(C) - import C_INT64_T, C_DOUBLE - integer(C_INT64_T), value :: i - real(C_DOUBLE) :: wgt - end function - - subroutine source_bank_xyz(i, xyz) bind(C) - import C_INT64_T, C_DOUBLE - integer(C_INT64_T), value :: i - real(C_DOUBLE), intent(in) :: xyz(*) - end subroutine - - function source_bank_E(i) result(E) bind(C, name='source_bank_E') - import C_INT64_T, C_DOUBLE - integer(C_INT64_T), value :: i - real(C_DOUBLE) :: E - end function - - function source_bank_wgt(i) result(wgt) bind(C) - import C_INT64_T, C_DOUBLE - integer(C_INT64_T), value :: i - real(C_DOUBLE) :: wgt - end function - - subroutine source_bank_set_wgt(i, wgt) bind(C) - import C_INT64_T, C_DOUBLE - integer(C_INT64_T), value :: i - real(C_DOUBLE), value :: wgt - end subroutine - end interface - -end module bank_header diff --git a/src/constants.F90 b/src/constants.F90 deleted file mode 100644 index ff74cd68a3..0000000000 --- a/src/constants.F90 +++ /dev/null @@ -1,166 +0,0 @@ -module constants - - use, intrinsic :: ISO_C_BINDING - - implicit none - - ! ============================================================================ - ! ADJUSTABLE PARAMETERS - - ! NOTE: This is the only section of the constants module that should ever be - ! adjusted. Modifying constants in other sections may cause the code to fail. - - ! Maximum number of secondary particles created - integer, parameter :: MAX_SECONDARY = 1000 - - ! Maximum number of words in a single line, length of line, and length of - ! single word - integer, parameter :: MAX_LINE_LEN = 250 - integer, parameter :: MAX_WORD_LEN = 150 - integer, parameter :: MAX_FILE_LEN = 255 - - ! ============================================================================ - ! PHYSICAL CONSTANTS - - ! Values here are from the Committee on Data for Science and Technology - ! (CODATA) 2014 recommendation (doi:10.1103/RevModPhys.88.035009). - - real(8), parameter :: & - PI = 3.1415926535898_8, & ! pi - INFINITY = huge(0.0_8), & ! positive infinity - ZERO = 0.0_8, & - HALF = 0.5_8, & - ONE = 1.0_8, & - TWO = 2.0_8 - - ! ============================================================================ - ! GEOMETRY-RELATED CONSTANTS - - ! Boundary conditions - integer(C_INT), bind(C, name="BC_TRANSMIT") :: BC_TRANSMIT - integer(C_INT), bind(C, name="BC_VACUUM") :: BC_VACUUM - integer(C_INT), bind(C, name="BC_REFLECT") :: BC_REFLECT - integer(C_INT), bind(C, name="BC_PERIODIC") :: BC_PERIODIC - - ! Cell fill types - integer, parameter :: & - FILL_MATERIAL = 1, & ! Cell with a specified material - FILL_UNIVERSE = 2, & ! Cell filled by a separate universe - FILL_LATTICE = 3 ! Cell filled with a lattice - integer(C_INT), bind(C, name='FILL_MATERIAL') :: FILL_MATERIAL_C = FILL_MATERIAL - integer(C_INT), bind(C, name='FILL_UNIVERSE') :: FILL_UNIVERSE_C = FILL_UNIVERSE - integer(C_INT), bind(C, name='FILL_LATTICE') :: FILL_LATTICE_C = FILL_LATTICE - - ! Void material - integer, parameter :: MATERIAL_VOID = -1 - - ! ============================================================================ - ! CROSS SECTION RELATED CONSTANTS - - ! Particle type - integer, parameter :: & - NEUTRON = 0, & - PHOTON = 1, & - ELECTRON = 2, & - POSITRON = 3 - - ! MGXS Table Types - integer, parameter :: & - MGXS_ISOTROPIC = 1, & ! Isotropically Weighted Data - MGXS_ANGLE = 2 ! Data by Angular Bins - - ! ============================================================================ - ! TALLY-RELATED CONSTANTS - - ! Tally result entries - integer, parameter :: & - RESULT_VALUE = 1, & - RESULT_SUM = 2, & - RESULT_SUM_SQ = 3 - - ! Tally type - integer, parameter :: & - TALLY_VOLUME = 1, & - TALLY_MESH_SURFACE = 2, & - TALLY_SURFACE = 3 - - ! Tally estimator types - integer, parameter :: & - ESTIMATOR_ANALOG = 1, & - ESTIMATOR_TRACKLENGTH = 2, & - ESTIMATOR_COLLISION = 3 - - ! Event types for tallies - integer, parameter :: & - EVENT_SURFACE = -2, & - EVENT_LATTICE = -1, & - EVENT_SCATTER = 1, & - EVENT_ABSORB = 2 - - ! Tally score type -- if you change these, make sure you also update the - ! _SCORES dictionary in openmc/capi/tally.py - integer, parameter :: N_SCORE_TYPES = 16 - integer, parameter :: & - SCORE_FLUX = -1, & ! flux - SCORE_TOTAL = -2, & ! total reaction rate - SCORE_SCATTER = -3, & ! scattering rate - SCORE_NU_SCATTER = -4, & ! scattering production rate - SCORE_ABSORPTION = -5, & ! absorption rate - SCORE_FISSION = -6, & ! fission rate - SCORE_NU_FISSION = -7, & ! neutron production rate - SCORE_KAPPA_FISSION = -8, & ! fission energy production rate - SCORE_CURRENT = -9, & ! current - SCORE_EVENTS = -10, & ! number of events - SCORE_DELAYED_NU_FISSION = -11, & ! delayed neutron production rate - SCORE_PROMPT_NU_FISSION = -12, & ! prompt neutron production rate - SCORE_INVERSE_VELOCITY = -13, & ! flux-weighted inverse velocity - SCORE_FISS_Q_PROMPT = -14, & ! prompt fission Q-value - SCORE_FISS_Q_RECOV = -15, & ! recoverable fission Q-value - SCORE_DECAY_RATE = -16 ! delayed neutron precursor decay rate - - ! Tally map bin finding - integer, parameter :: NO_BIN_FOUND = -1 - - ! Tally filter and map types - integer, parameter :: & - FILTER_UNIVERSE = 1, & - FILTER_MATERIAL = 2, & - FILTER_CELL = 3 - - ! Differential tally independent variables - integer, parameter :: & - DIFF_DENSITY = 1, & - DIFF_NUCLIDE_DENSITY = 2, & - DIFF_TEMPERATURE = 3 - - ! ============================================================================ - ! MISCELLANEOUS CONSTANTS - - ! indicates that an array index hasn't been set - integer, parameter :: NONE = 0 - integer, parameter :: C_NONE = -1 - - ! Codes for read errors -- better hope these numbers are never used in an - ! input file! - integer, parameter :: ERROR_INT = -huge(0) - real(8), parameter :: ERROR_REAL = -huge(0.0_8) * 0.917826354_8 - - ! Running modes - integer, parameter :: & - MODE_FIXEDSOURCE = 1, & ! Fixed source mode - MODE_EIGENVALUE = 2, & ! K eigenvalue mode - MODE_PLOTTING = 3, & ! Plotting mode - MODE_PARTICLE = 4, & ! Particle restart mode - MODE_VOLUME = 5 ! Volume calculation mode - - !============================================================================= - ! DELAYED NEUTRON PRECURSOR CONSTANTS - - ! Since cross section libraries come with different numbers of delayed groups - ! (e.g. ENDF/B-VII.1 has 6 and JEFF 3.1.1 has 8 delayed groups) and we don't - ! yet know what cross section library is being used when the tallies.xml file - ! is read in, we want to have an upper bound on the size of the array we - ! use to store the bins for delayed group tallies. - integer, parameter :: MAX_DELAYED_GROUPS = 8 - -end module constants diff --git a/src/dict_header.F90 b/src/dict_header.F90 deleted file mode 100644 index d2bf717210..0000000000 --- a/src/dict_header.F90 +++ /dev/null @@ -1,541 +0,0 @@ -module dict_header - -!=============================================================================== -! DICT_HEADER module -! -! This module provides an implementation of a dictionary that has (key,value) -! pairs. This data structure is used to provide lookup features, e.g. cells and -! surfaces by name. -! -! The implementation is based on Algorithm D from Knuth Vol. 3 Sec. 6.4 (open -! addressing with double hashing). Hash table sizes M are chosen such that M -! and M - 2 are twin primes, which helps reduce clustering. The sequence of -! twin primes used for the table sizes comes from -! https://github.com/anholt/hash_table/blob/master/hash_table.c. These values -! were selected so that the table would grow by approximately a factor of two -! each time the maximum load factor is exceeded. An upper limit is placed on -! the load factor to prevent exponential performance degradation as the number -! of entries approaches the number of buckets. -!=============================================================================== - - implicit none - - integer, parameter :: EMPTY = -huge(0) - integer, parameter, private :: DELETED = -huge(0) + 1 - integer, parameter, private :: KEY_CHAR_LENGTH = 255 - integer, parameter, private :: TABLE_SIZES(30) = & - [5, 7, 13, 19, 43, 73, 151, 283, 571, 1153, 2269, 4519, 9013, 18043, & - 36109, 72091, 144409, 288361, 576883, 1153459, 2307163, 4613893, & - 9227641, 18455029, 36911011, 73819861, 147639589, 295279081, & - 590559793, 1181116273] - real(8), parameter, private :: MAX_LOAD_FACTOR = 0.65 - -!=============================================================================== -! DICTENTRY* contains (key,value) pairs. -!=============================================================================== - - type DictEntryII - integer :: key = EMPTY - integer :: value = EMPTY - end type DictEntryII - - type DictEntryCI - character(len=KEY_CHAR_LENGTH) :: key - integer :: value = EMPTY - end type DictEntryCI - -!=============================================================================== -! BUCKET* contains an allocatable DictEntry object for storing a (key,value) -! pair and the hash value for fast comparisons. Integer (key,value) pairs are -! stored directly in the hash table since their memory requirement is small. -!=============================================================================== - - type, private :: BucketCI - type(DictEntryCI), allocatable :: entry - integer :: hash = EMPTY - end type BucketCI - -!=============================================================================== -! DICT* is a dictionary of (key,value) pairs with convenience methods as -! type-bound procedures. DictIntInt has integer keys and values, and -! DictCharInt has character(*) keys and integer values. -!=============================================================================== - - type, public :: DictIntInt - integer, private :: entries = 0 - integer, private :: capacity = 0 - type(DictEntryII), allocatable, private :: table(:) - contains - procedure :: set => set_ii - procedure :: get => get_ii - procedure :: has => has_ii - procedure :: remove => remove_ii - procedure :: next_entry => next_entry_ii - procedure :: clear => clear_ii - procedure :: size => size_ii - procedure, private :: get_entry => get_entry_ii - procedure, private :: resize => resize_ii - end type DictIntInt - - type, public :: DictCharInt - integer, private :: entries = 0 - integer, private :: capacity = 0 - type(BucketCI), allocatable, private :: table(:) - contains - procedure :: set => set_ci - procedure :: get => get_ci - procedure :: has => has_ci - procedure :: remove => remove_ci - procedure :: next_entry => next_entry_ci - procedure :: clear => clear_ci - procedure :: size => size_ci - procedure, private :: get_entry => get_entry_ci - procedure, private :: resize => resize_ci - end type DictCharInt - -contains - -!=============================================================================== -! GET_ENTRY returns the index of the (key,value) pair in the table for a given -! key. This method is private. -!=============================================================================== - - function get_entry_ii(this, key) result(i) - - class(DictIntInt) :: this - integer, intent(in) :: key - integer :: i - - integer :: hash - integer :: c - - if (.not. allocated(this % table)) then - allocate(this % table(TABLE_SIZES(1))) - this % capacity = TABLE_SIZES(1) - end if - - hash = hash_ii(key) - i = 1 + mod(hash, this % capacity) - c = 2 + mod(hash, this % capacity - 2) - - do - if (this % table(i) % key == key .or. & - this % table(i) % key == EMPTY) exit - - i = 1 + mod(i + c - 1, this % capacity) - end do - - end function get_entry_ii - - function get_entry_ci(this, key) result(i) - - class(DictCharInt) :: this - character(*), intent(in) :: key - integer :: i - - integer :: hash - integer :: c - - if (.not. allocated(this % table)) then - allocate(this % table(TABLE_SIZES(1))) - this % capacity = TABLE_SIZES(1) - end if - - hash = hash_ci(key) - i = 1 + mod(hash, this % capacity) - c = 2 + mod(hash, this % capacity - 2) - - do - if (this % table(i) % hash == hash) then - if (allocated(this % table(i) % entry)) then - if (this % table(i) % entry % key == key) exit - end if - end if - - if (this % table(i) % hash == EMPTY) exit - - i = 1 + mod(i + c - 1, this % capacity) - end do - - end function get_entry_ci - -!=============================================================================== -! RESIZE allocates a new hash table to accomodate the number of entries and -! reinserts all of the entries into the new table. This method is private. -!=============================================================================== - - subroutine resize_ii(this) - - class(DictIntInt) :: this - - type(DictEntryII), allocatable :: table(:) - integer :: new_size - integer :: i - - do i = 1, size(TABLE_SIZES) - if (TABLE_SIZES(i) > this % capacity) exit - end do - new_size = TABLE_SIZES(i) - - call move_alloc(this % table, table) - allocate(this % table(new_size)) - this % capacity = new_size - this % entries = 0 - - ! Rehash each entry into the new table - do i = 1, size(table) - if (table(i) % key /= EMPTY .and. table(i) % key /= DELETED) then - call this % set(table(i) % key, table(i) % value) - end if - end do - - deallocate(table) - - end subroutine resize_ii - - subroutine resize_ci(this) - - class(DictCharInt) :: this - - type(BucketCI), allocatable :: table(:) - integer :: new_size - integer :: i - - do i = 1, size(TABLE_SIZES) - if (TABLE_SIZES(i) > this % capacity) exit - end do - new_size = TABLE_SIZES(i) - - call move_alloc(this % table, table) - allocate(this % table(new_size)) - this % capacity = new_size - this % entries = 0 - - ! Rehash each entry into the new table - do i = 1, size(table) - if (table(i) % hash /= EMPTY .and. table(i) % hash /= DELETED) then - call this % set(table(i) % entry % key, table(i) % entry % value) - end if - end do - - deallocate(table) - - end subroutine resize_ci - -!=============================================================================== -! SET adds a (key,value) entry to a dictionary. If the key is already in the -! dictionary, the value is replaced by the new specified value. -!=============================================================================== - - subroutine set_ii(this, key, value) - - class(DictIntInt) :: this - integer, intent(in) :: key - integer, intent(in) :: value - - integer :: hash - integer :: i - integer :: c - - if (.not. allocated(this % table)) then - allocate(this % table(TABLE_SIZES(1))) - this % capacity = TABLE_SIZES(1) - else if (real(this % entries + 1, 8) / this % capacity > MAX_LOAD_FACTOR) then - call this % resize() - end if - - hash = hash_ii(key) - i = 1 + mod(hash, this % capacity) - c = 2 + mod(hash, this % capacity - 2) - - do - if (this % table(i) % key == EMPTY .or. & - this % table(i) % key == DELETED) then - this % table(i) % key = key - this % table(i) % value = value - this % entries = this % entries + 1 - exit - else if (this % table(i) % key == key) then - this % table(i) % value = value - exit - end if - - i = 1 + mod(i + c - 1, this % capacity) - end do - - end subroutine set_ii - - subroutine set_ci(this, key, value) - - class(DictCharInt) :: this - character(*), intent(in) :: key - integer, intent(in) :: value - - integer :: hash - integer :: i - integer :: c - - if (.not. allocated(this % table)) then - allocate(this % table(TABLE_SIZES(1))) - this % capacity = TABLE_SIZES(1) - else if (real(this % entries + 1, 8) / this % capacity > MAX_LOAD_FACTOR) then - call this % resize() - end if - - hash = hash_ci(key) - i = 1 + mod(hash, this % capacity) - c = 2 + mod(hash, this % capacity - 2) - - do - if (this % table(i) % hash == EMPTY .or. & - this % table(i) % hash == DELETED) then - if (.not. allocated(this % table(i) % entry)) then - allocate(this % table(i) % entry) - end if - this % table(i) % hash = hash - this % table(i) % entry % key = key - this % table(i) % entry % value = value - this % entries = this % entries + 1 - exit - else if (this % table(i) % hash == hash .and. & - this % table(i) % entry % key == key) then - this % table(i) % entry % value = value - exit - end if - - i = 1 + mod(i + c - 1, this % capacity) - end do - - end subroutine set_ci - -!=============================================================================== -! GET returns the value matching a given key. If the dictionary does not contain -! the key, the value EMPTY is returned. -!=============================================================================== - - function get_ii(this, key) result(value) - - class(DictIntInt) :: this - integer, intent(in) :: key - integer :: value - - integer :: i - - i = this % get_entry(key) - value = this % table(i) % value - - end function get_ii - - function get_ci(this, key) result(value) - - class(DictCharInt) :: this - character(*), intent(in) :: key - integer :: value - - integer :: i - - i = this % get_entry(key) - if (allocated(this % table(i) % entry)) then - value = this % table(i) % entry % value - else - value = EMPTY - end if - - end function get_ci - -!=============================================================================== -! HAS determines whether a dictionary has a (key,value) pair with a given key. -!=============================================================================== - - function has_ii(this, key) result(has) - - class(DictIntInt) :: this - integer, intent(in) :: key - logical :: has - - integer :: i - - i = this % get_entry(key) - has = (this % table(i) % key /= EMPTY) - - end function has_ii - - function has_ci(this, key) result(has) - - class(DictCharInt) :: this - character(*), intent(in) :: key - logical :: has - - integer :: i - - i = this % get_entry(key) - has = (this % table(i) % hash /= EMPTY) - - end function has_ci - -!=============================================================================== -! REMOVE deletes a (key,value) entry from a dictionary. -!=============================================================================== - - subroutine remove_ii(this, key) - - class(DictIntInt) :: this - integer, intent(in) :: key - - integer :: i - - i = this % get_entry(key) - if (this % table(i) % key /= EMPTY) then - this % table(i) % key = DELETED - this % table(i) % value = EMPTY - this % entries = this % entries - 1 - end if - - end subroutine remove_ii - - subroutine remove_ci(this, key) - - class(DictCharInt) :: this - character(*), intent(in) :: key - - integer :: i - - i = this % get_entry(key) - if (this % table(i) % hash /= EMPTY) then - this % table(i) % hash = DELETED - if (allocated(this % table(i) % entry)) then - deallocate(this % table(i) % entry) - end if - this % entries = this % entries - 1 - end if - - end subroutine remove_ci - -!=============================================================================== -! NEXT_ENTRY finds the next (key,value) pair. The value of current_entry is -! updated with the (key,value) pair, and the value of i is updated with the -! index of the entry in the table. Passing in i = 0 will locate the first entry -! in the dictionary. If there are no more entries, i will be set to 0. -!=============================================================================== - - subroutine next_entry_ii(this, current_entry, i) - - class(DictIntInt) :: this - type(DictEntryII), intent(inout) :: current_entry - integer, intent(inout) :: i - - if (.not. allocated(this % table)) return - - do - i = i + 1 - if (i > size(this % table)) then - i = 0 - exit - else if (this % table(i) % key /= EMPTY .and. & - this % table(i) % key /= DELETED) then - current_entry = this % table(i) - exit - end if - end do - - end subroutine next_entry_ii - - subroutine next_entry_ci(this, current_entry, i) - - class(DictCharInt) :: this - type(DictEntryCI), intent(inout) :: current_entry - integer, intent(inout) :: i - - if (.not. allocated(this % table)) return - - do - i = i + 1 - if (i > size(this % table)) then - i = 0 - exit - else if (this % table(i) % hash /= EMPTY .and. & - this % table(i) % hash /= DELETED) then - current_entry = this % table(i) % entry - exit - end if - end do - - end subroutine next_entry_ci - -!=============================================================================== -! CLEAR deletes and deallocates the dictionary item -!=============================================================================== - - subroutine clear_ii(this) - - class(DictIntInt) :: this - - if (allocated(this % table)) deallocate(this % table) - this % entries = 0 - this % capacity = 0 - - end subroutine clear_ii - - subroutine clear_ci(this) - - class(DictCharInt) :: this - - if (allocated(this % table)) deallocate(this % table) - this % entries = 0 - this % capacity = 0 - - end subroutine clear_ci - -!=============================================================================== -! SIZE returns the number of entries in the dictionary -!=============================================================================== - - pure function size_ii(this) result(size) - - class(DictIntInt), intent(in) :: this - integer :: size - - size = this % entries - - end function size_ii - - pure function size_ci(this) result(size) - - class(DictCharInt), intent(in) :: this - integer :: size - - size = this % entries - - end function size_ci - -!=============================================================================== -! HASH returns the hash value for a given key -!=============================================================================== - - pure function hash_ii(key) result(hash) - - integer, intent(in) :: key - integer :: hash - - hash = abs(key - 1) - - end function hash_ii - - pure function hash_ci(key) result(hash) - - character(*), intent(in) :: key - integer :: hash - - integer :: i - - hash = 0 - - do i = 1, len_trim(key) - hash = 31 * hash + ichar(key(i:i)) - end do - - hash = abs(hash - 1) - - end function hash_ci - -end module dict_header diff --git a/src/error.F90 b/src/error.F90 deleted file mode 100644 index ca94c6ce71..0000000000 --- a/src/error.F90 +++ /dev/null @@ -1,258 +0,0 @@ -module error - - use, intrinsic :: ISO_C_BINDING - use, intrinsic :: ISO_FORTRAN_ENV - - use constants - use message_passing - use settings, only: verbosity - - implicit none - - private - public :: fatal_error - public :: warning - public :: write_message - - ! Error codes - integer(C_INT), public, bind(C, name='OPENMC_E_UNASSIGNED') :: E_UNASSIGNED = -1 - integer(C_INT), public, bind(C, name='OPENMC_E_ALLOCATE') :: E_ALLOCATE = -2 - integer(C_INT), public, bind(C, name='OPENMC_E_OUT_OF_BOUNDS') :: E_OUT_OF_BOUNDS = -3 - integer(C_INT), public, bind(C, name='OPENMC_E_INVALID_SIZE') :: E_INVALID_SIZE = -4 - integer(C_INT), public, bind(C, name='OPENMC_E_INVALID_ARGUMENT') :: E_INVALID_ARGUMENT = -5 - integer(C_INT), public, bind(C, name='OPENMC_E_INVALID_TYPE') :: E_INVALID_TYPE = -6 - integer(C_INT), public, bind(C, name='OPENMC_E_INVALID_ID') :: E_INVALID_ID = -7 - integer(C_INT), public, bind(C, name='OPENMC_E_GEOMETRY') :: E_GEOMETRY = -8 - integer(C_INT), public, bind(C, name='OPENMC_E_DATA') :: E_DATA = -9 - integer(C_INT), public, bind(C, name='OPENMC_E_PHYSICS') :: E_PHYSICS = -10 - - ! Warning codes - integer(C_INT), public, bind(C, name='OPENMC_E_WARNING') :: E_WARNING = 1 - - ! Error message - character(kind=C_CHAR), public, bind(C) :: openmc_err_msg(256) - - public :: set_errmsg - -contains - -!=============================================================================== -! SET_ERRMSG sets the 'openmc_err_msg' module variable that is exposed via the C -! API -!=============================================================================== - - subroutine set_errmsg(f_string) - character(*), intent(in) :: f_string - - integer :: i, n - - ! Copy Fortran string to null-terminated C char array - n = len_trim(f_string) - do i = 1, n - openmc_err_msg(i) = f_string(i:i) - end do - openmc_err_msg(n + 1) = C_NULL_CHAR - end subroutine set_errmsg - -!=============================================================================== -! WARNING issues a warning to the user in the log file and the standard output -! stream. -!=============================================================================== - - subroutine warning(message) - - character(*) :: message - - integer :: i_start ! starting position - integer :: i_end ! ending position - integer :: line_wrap ! length of line - integer :: length ! length of message - integer :: indent ! length of indentation - - ! Write warning at beginning - write(ERROR_UNIT, fmt='(1X,A)', advance='no') 'WARNING: ' - - ! Set line wrapping and indentation - line_wrap = 80 - indent = 10 - - ! Determine length of message - length = len_trim(message) - - i_start = 0 - do - if (length - i_start < line_wrap - indent + 1) then - ! Remainder of message will fit on line - write(ERROR_UNIT, fmt='(A)') message(i_start+1:length) - exit - - else - ! Determine last space in current line - i_end = i_start + index(message(i_start+1:i_start+line_wrap-indent+1), & - ' ', BACK=.true.) - - if (i_end == i_start) then - ! This is a special case where there is no space - i_end = i_start + line_wrap - indent + 1 - write(ERROR_UNIT, fmt='(A/A)', advance='no') & - message(i_start+1:i_end-1), repeat(' ', indent) - i_end = i_end - 1 - else - ! Write up to last space - write(ERROR_UNIT, fmt='(A/A)', advance='no') & - message(i_start+1:i_end-1), repeat(' ', indent) - end if - - ! Advance starting position - i_start = i_end - if (i_start > length) exit - end if - end do - - end subroutine warning - -!=============================================================================== -! FATAL_ERROR alerts the user that an error has been encountered and displays a -! message about the particular problem. Errors are considered 'fatal' and hence -! the program is aborted. -!=============================================================================== - - subroutine fatal_error(message, error_code) - - character(*) :: message - integer, optional :: error_code ! error code - - integer(C_INT) :: code ! error code - integer :: i_start ! starting position - integer :: i_end ! ending position - integer :: line_wrap ! length of line - integer :: length ! length of message - integer :: indent ! length of indentation - -#ifdef OPENMC_MPI - interface - subroutine abort_mpi(code) bind(C) - import C_INT - integer(C_INT), value :: code - end subroutine - end interface -#endif - - - ! set default error code - if (present(error_code)) then - code = error_code - else - code = -1 - end if - - ! Write error at beginning - write(ERROR_UNIT, fmt='(1X,A)', advance='no') 'ERROR: ' - - ! Set line wrapping and indentation - line_wrap = 80 - indent = 8 - - ! Determine length of message - length = len_trim(message) - - i_start = 0 - do - if (length - i_start < line_wrap - indent + 1) then - ! Remainder of message will fit on line - write(ERROR_UNIT, fmt='(A)') message(i_start+1:length) - exit - - else - ! Determine last space in current line - i_end = i_start + index(message(i_start+1:i_start+line_wrap-indent+1), & - ' ', BACK=.true.) - - if (i_end == i_start) then - ! This is a special case where there is no space - i_end = i_start + line_wrap - indent + 1 - write(ERROR_UNIT, fmt='(A/A)', advance='no') & - message(i_start+1:i_end-1), repeat(' ', indent) - i_end = i_end - 1 - else - ! Write up to last space - write(ERROR_UNIT, fmt='(A/A)', advance='no') & - message(i_start+1:i_end-1), repeat(' ', indent) - end if - - ! Advance starting position - i_start = i_end - if (i_start > length) exit - end if - end do - -#ifdef OPENMC_MPI - ! Abort MPI - call abort_mpi(code) -#endif - - ! Abort program -#ifdef NO_F2008 - stop -#else - error stop -#endif - - end subroutine fatal_error - -!=============================================================================== -! WRITE_MESSAGE displays an informational message to the log file and the -! standard output stream. -!=============================================================================== - - subroutine write_message(message, level) - character(*), intent(in) :: message ! message to write - integer, intent(in), optional :: level ! verbosity level - - integer :: i_start ! starting position - integer :: i_end ! ending position - integer :: line_wrap ! length of line - integer :: length ! length of message - integer :: last_space ! index of last space (relative to start) - - ! Set length of line - line_wrap = 80 - - ! Only allow master to print to screen - if (.not. master .and. present(level)) return - - if (.not. present(level) .or. level <= verbosity) then - ! Determine length of message - length = len_trim(message) - - i_start = 0 - do - if (length - i_start < line_wrap + 1) then - ! Remainder of message will fit on line - write(OUTPUT_UNIT, fmt='(1X,A)') message(i_start+1:length) - exit - - else - ! Determine last space in current line - last_space = index(message(i_start+1:i_start+line_wrap), & - ' ', BACK=.true.) - if (last_space == 0) then - i_end = min(length + 1, i_start+line_wrap) - 1 - write(OUTPUT_UNIT, fmt='(1X,A)') message(i_start+1:i_end) - else - i_end = i_start + last_space - write(OUTPUT_UNIT, fmt='(1X,A)') message(i_start+1:i_end-1) - end if - - ! Write up to last space - - ! Advance starting position - i_start = i_end - if (i_start > length) exit - end if - end do - end if - - end subroutine write_message - -end module error diff --git a/src/error.cpp b/src/error.cpp index cc63c9bc3d..83e7e8781e 100644 --- a/src/error.cpp +++ b/src/error.cpp @@ -11,6 +11,30 @@ #include // for setw #include +//============================================================================== +// Global variables / constants +//============================================================================== + +// Error codes +int OPENMC_E_UNASSIGNED {-1}; +int OPENMC_E_ALLOCATE {-2}; +int OPENMC_E_OUT_OF_BOUNDS {-3}; +int OPENMC_E_INVALID_SIZE {-4}; +int OPENMC_E_INVALID_ARGUMENT {-5}; +int OPENMC_E_INVALID_TYPE {-6}; +int OPENMC_E_INVALID_ID {-7}; +int OPENMC_E_GEOMETRY {-8}; +int OPENMC_E_DATA {-9}; +int OPENMC_E_PHYSICS {-10}; +int OPENMC_E_WARNING {1}; + +// Error message +char openmc_err_msg[256]; + +//============================================================================== +// Functions +//============================================================================== + namespace openmc { #ifdef OPENMC_MPI diff --git a/src/geometry.F90 b/src/geometry.F90 deleted file mode 100644 index 1b7ead90aa..0000000000 --- a/src/geometry.F90 +++ /dev/null @@ -1,73 +0,0 @@ -module geometry - - use constants - use particle_header - use simulation_header - use settings - - use, intrinsic :: ISO_C_BINDING - - implicit none - - interface - function count_universe_instances(search_univ, target_univ_id) bind(C) & - result(count) - import C_INT32_T, C_INT - integer(C_INT32_T), intent(in), value :: search_univ - integer(C_INT32_T), intent(in), value :: target_univ_id - integer(C_INT) :: count - end function count_universe_instances - - subroutine check_cell_overlap(p) bind(C) - import Particle - type(Particle), intent(in) :: p - end subroutine check_cell_overlap - - function find_cell_c(p, use_neighbor_lists) & - bind(C, name="find_cell") result(found) - import Particle, C_INT, C_BOOL - type(Particle), intent(inout) :: p - logical(C_BOOL), intent(in), value :: use_neighbor_lists - logical(C_BOOL) :: found - end function find_cell_c - - subroutine cross_lattice(p, lattice_translation) & - bind(C, name="cross_lattice") - import Particle, C_INT - type(Particle), intent(inout) :: p - integer(C_INT), intent(in) :: lattice_translation(3) - end subroutine cross_lattice - - subroutine distance_to_boundary(p, dist, surface_crossed, & - lattice_translation, next_level) bind(C) - import Particle, C_DOUBLE, C_INT - type(Particle), intent(inout) :: p - real(C_DOUBLE), intent(out) :: dist - integer(C_INT), intent(out) :: surface_crossed - integer(C_INT), intent(out) :: lattice_translation(3) - integer(C_INT), intent(out) :: next_level - end subroutine distance_to_boundary - end interface - -contains - -!=============================================================================== -! FIND_CELL determines what cell a source particle is in within a particular -! universe. If the base universe is passed, the particle should be found as long -! as it's within the geometry -!=============================================================================== - - subroutine find_cell(p, found, use_neighbor_lists) - type(Particle), intent(inout) :: p - logical, intent(inout) :: found - logical, optional, intent(in) :: use_neighbor_lists - - if (present(use_neighbor_lists)) then - found = find_cell_c(p, logical(use_neighbor_lists, kind=C_BOOL)) - else - found = find_cell_c(p, .false._C_BOOL) - end if - - end subroutine find_cell - -end module geometry diff --git a/src/hdf5_interface.F90 b/src/hdf5_interface.F90 deleted file mode 100644 index 7856abb507..0000000000 --- a/src/hdf5_interface.F90 +++ /dev/null @@ -1,1445 +0,0 @@ -module hdf5_interface - -!============================================================================== -! HDF5_INTERFACE -- This module provides the high-level procedures which greatly -! simplify writing/reading different types of data to HDF5 files. In order to -! get it to work with gfotran 4.6, all the write__ND subroutines had to be -! split into two procedures, one accepting an assumed-shape array and another -! one with an explicit-shape array since in gfortran 4.6 C_LOC does not work -! with an assumed-shape array. When we move to gfortran 4.9+, these procedures -! can be combined into one simply accepting an assumed-shape array. -!============================================================================== - - use, intrinsic :: ISO_C_BINDING - - use error, only: fatal_error - use string, only: to_c_string, to_f_string - - implicit none - private - - interface write_dataset - module procedure write_double_0D - module procedure write_double_1D - module procedure write_double_2D - module procedure write_double_3D - module procedure write_double_4D - module procedure write_integer_0D - module procedure write_integer_1D - module procedure write_integer_2D - module procedure write_integer_3D - module procedure write_integer_4D - module procedure write_long - module procedure write_string - module procedure write_string_1D - end interface write_dataset - - interface read_dataset - module procedure read_double_0D - module procedure read_double_1D - module procedure read_double_2D - module procedure read_double_3D - module procedure read_double_4D - module procedure read_integer_0D - module procedure read_integer_1D - module procedure read_integer_2D - module procedure read_integer_3D - module procedure read_integer_4D - module procedure read_long - module procedure read_string - module procedure read_string_1D - module procedure read_complex_2D - end interface read_dataset - - interface read_attribute - module procedure read_attribute_double - module procedure read_attribute_double_1D - module procedure read_attribute_double_2D - module procedure read_attribute_integer - module procedure read_attribute_integer_1D - module procedure read_attribute_integer_2D - module procedure read_attribute_string - module procedure read_attribute_string_1D - module procedure read_attribute_logical - end interface read_attribute - - interface write_attribute - module procedure write_attribute_double - module procedure write_attribute_double_1D - module procedure write_attribute_integer - module procedure write_attribute_integer_1D - module procedure write_attribute_string - end interface write_attribute - - public :: write_dataset - public :: read_dataset - public :: attribute_exists - public :: write_attribute - public :: read_attribute - public :: file_open - public :: file_close - public :: create_group - public :: object_exists - public :: open_group - public :: close_group - public :: open_dataset - public :: close_dataset - public :: get_shape - public :: get_ndims - public :: get_groups - public :: get_datasets - public :: get_name - - integer, public, parameter :: HID_T = C_INT64_T - integer, public, parameter :: HSIZE_T = C_LONG_LONG - - interface - function attribute_typesize(obj_id, name) result(sz) bind(C) - import HID_T, C_CHAR, C_SIZE_T - integer(HID_T), value :: obj_id - character(kind=C_CHAR), intent(in) :: name(*) - integer(C_SIZE_T) :: sz - end function attribute_typesize - - function dataset_typesize(dset) result(sz) bind(C) - import HID_T, C_SIZE_T - integer(HID_T), value :: dset - integer(C_SIZE_T) :: sz - end function dataset_typesize - - subroutine file_close(file_id) bind(C) - import HID_T - integer(HID_T), value :: file_id - end subroutine file_close - - subroutine get_shape_c(obj_id, dims) bind(C, name='get_shape') - import HID_T, HSIZE_T - integer(HID_T), value :: obj_id - integer(HSIZE_T), intent(out) :: dims(*) - end subroutine get_shape_c - - subroutine get_shape_attr(obj_id, name, dims) bind(C) - import HID_T, HSIZE_T, C_CHAR - integer(HID_T), value :: obj_id - character(kind=C_CHAR), intent(in) :: name(*) - integer(HSIZE_T), intent(out) :: dims(*) - end subroutine get_shape_attr - - subroutine read_double_c(obj_id, name, buffer, indep) & - bind(C, name='read_double') - import HID_T, C_DOUBLE, C_BOOL, C_PTR - integer(HID_T), value :: obj_id - type(C_PTR), value :: name - real(C_DOUBLE), intent(out) :: buffer(*) - logical(C_BOOL), value :: indep - end subroutine read_double_c - - subroutine read_attr_int_c(obj_id, name, buffer) & - bind(C, name='read_attr_int') - import HID_T, C_CHAR, C_INT - integer(HID_T), value :: obj_id - character(kind=C_CHAR), intent(in) :: name(*) - integer(C_INT), intent(out) :: buffer(*) - end subroutine read_attr_int_c - - subroutine read_attr_double_c(obj_id, name, buffer) & - bind(C, name='read_attr_double') - import HID_T, C_CHAR, C_DOUBLE - integer(HID_T), value :: obj_id - character(kind=C_CHAR), intent(in) :: name(*) - real(C_DOUBLE), intent(out) :: buffer(*) - end subroutine read_attr_double_c - - subroutine read_attr_string_c(obj_id, name, slen, buffer) & - bind(C, name='read_attr_string') - import HID_T, C_CHAR, C_SIZE_T - integer(HID_T), value :: obj_id - character(kind=C_CHAR), intent(in) :: name(*) - integer(C_SIZE_T), value :: slen - character(kind=C_CHAR), intent(out) :: buffer(*) - end subroutine read_attr_string_c - - subroutine read_int_c(obj_id, name, buffer, indep) & - bind(C, name='read_int') - import HID_T, C_INT, C_BOOL, C_PTR - integer(HID_T), value :: obj_id - type(C_PTR), value :: name - integer(C_INT), intent(out) :: buffer(*) - logical(C_BOOL), value :: indep - end subroutine read_int_c - - subroutine read_llong_c(obj_id, name, buffer, indep) & - bind(C, name='read_llong') - import HID_T, C_INT, C_BOOL, C_PTR, C_LONG_LONG - integer(HID_T), value :: obj_id - type(C_PTR), value :: name - integer(C_LONG_LONG), intent(out) :: buffer(*) - logical(C_BOOL), value :: indep - end subroutine read_llong_c - - subroutine read_string_c(obj_id, name, slen, buffer, indep) & - bind(C, name='read_string') - import HID_T, C_PTR, C_SIZE_T, C_CHAR, C_BOOL - integer(HID_T), value :: obj_id - type(C_PTR), value :: name - integer(C_SIZE_T), value :: slen - character(kind=C_CHAR), intent(out) :: buffer(*) - logical(C_BOOL), value :: indep - end subroutine read_string_c - - subroutine read_complex_c(obj_id, name, buffer, indep) & - bind(C, name='read_complex') - import HID_T, C_PTR, C_DOUBLE_COMPLEX, C_BOOL - integer(HID_T), value :: obj_id - type(C_PTR), value :: name - complex(C_DOUBLE_COMPLEX), intent(out) :: buffer(*) - logical(C_BOOL), value :: indep - end subroutine read_complex_c - - subroutine write_attr_double_c(obj_id, ndim, dims, name, buffer) & - bind(C, name='write_attr_double') - import HID_T, HSIZE_T, C_INT, C_DOUBLE, C_CHAR - integer(HID_T), value :: obj_id - integer(C_INT), value :: ndim - integer(HSIZE_T), intent(in) :: dims(*) - character(kind=C_CHAR), intent(in) :: name(*) - real(C_DOUBLE), intent(in) :: buffer(*) - end subroutine write_attr_double_c - - subroutine write_attr_int_c(obj_id, ndim, dims, name, buffer) & - bind(C, name='write_attr_int') - import HID_T, HSIZE_T, C_INT, C_CHAR - integer(HID_T), value :: obj_id - integer(C_INT), value :: ndim - integer(HSIZE_T), intent(in) :: dims(*) - character(kind=C_CHAR), intent(in) :: name(*) - integer(C_INT), intent(in) :: buffer(*) - end subroutine write_attr_int_c - - subroutine write_attr_string_c(obj_id, name, buffer) & - bind(C, name='write_attr_string') - import HID_T, C_CHAR - integer(HID_T), value :: obj_id - character(kind=C_CHAR), intent(in) :: name(*) - character(kind=C_CHAR), intent(in) :: buffer(*) - end subroutine write_attr_string_c - - subroutine write_double_c(group_id, ndim, dims, name, buffer, indep) & - bind(C, name='write_double') - import HID_T, HSIZE_T, C_INT, C_DOUBLE, C_CHAR, C_BOOL - integer(HID_T), value :: group_id - integer(C_INT), value :: ndim - integer(HSIZE_T), intent(in) :: dims(*) - character(kind=C_CHAR), intent(in) :: name(*) - real(C_DOUBLE), intent(in) :: buffer(*) - logical(C_BOOL), value :: indep - end subroutine write_double_c - - subroutine write_int_c(group_id, ndim, dims, name, buffer, indep) & - bind(C, name='write_int') - import HID_T, HSIZE_T, C_INT, C_CHAR, C_BOOL - integer(HID_T), value :: group_id - integer(C_INT), value :: ndim - integer(HSIZE_T), intent(in) :: dims(*) - character(kind=C_CHAR), intent(in) :: name(*) - integer(C_INT), intent(in) :: buffer(*) - logical(C_BOOL), value :: indep - end subroutine write_int_c - - subroutine write_llong_c(group_id, ndim, dims, name, buffer, indep) & - bind(C, name='write_llong') - import HID_T, HSIZE_T, C_INT, C_CHAR, C_BOOL, C_LONG_LONG - integer(HID_T), value :: group_id - integer(C_INT), value :: ndim - integer(HSIZE_T), intent(in) :: dims(*) - character(kind=C_CHAR), intent(in) :: name(*) - integer(C_LONG_LONG), intent(in) :: buffer(*) - logical(C_BOOL), value :: indep - end subroutine write_llong_c - - subroutine write_string_c(group_id, ndim, dims, slen, name, buffer, indep) & - bind(C, name='write_string') - import HID_T, HSIZE_T, C_INT, C_CHAR, C_BOOL, C_SIZE_T - integer(HID_T), value :: group_id - integer(C_INT), value :: ndim - integer(HSIZE_T), intent(in) :: dims(*) - integer(C_SIZE_T), value :: slen - character(kind=C_CHAR), intent(in) :: name(*) - character(kind=C_CHAR), intent(in) :: buffer(*) - logical(C_BOOL), value :: indep - end subroutine write_string_c - end interface - -contains - -!=============================================================================== -! FILE_OPEN opens HDF5 file -!=============================================================================== - - function file_open(filename, mode, parallel) result(file_id) - character(*), intent(in) :: filename ! name of file - character, value :: mode ! access mode to file - logical, optional, intent(in) :: parallel ! whether to write in serial - integer(HID_T) :: file_id - - character(kind=C_CHAR) :: mode_ - logical(C_BOOL) :: parallel_ - - interface - function file_open_c(name, mode, parallel) bind(C, name='file_open') result(file_id) - import HID_T, C_CHAR, C_BOOL, C_INT - character(kind=C_CHAR) :: name(*) - character(kind=C_CHAR), value :: mode - logical(C_BOOL), value :: parallel - integer(HID_T) :: file_id - end function file_open_c - end interface - - mode_ = mode - parallel_ = .false. -#ifdef PHDF5 - if (present(parallel)) parallel_ = parallel -#endif - - file_id = file_open_c(to_c_string(filename), mode, parallel_) - end function file_open - -!=============================================================================== -! GET_GROUPS Gets a list of all the groups in a given location. -!=============================================================================== - - subroutine get_groups(object_id, names) - integer(HID_T), intent(in) :: object_id - character(len=150), allocatable, intent(out) :: names(:) - - integer :: i - integer(C_INT) :: n - character(len=150,kind=C_CHAR), target, allocatable :: names_(:) - type(C_PTR), allocatable :: name_ptrs(:) - - interface - function get_num_groups(group_id) result(n) bind(C) - import HID_T, C_INT - integer(HID_T), value :: group_id - integer(C_INT) :: n - end function get_num_groups - subroutine get_groups_c(group_id, name) bind(C, name='get_groups') - import HID_T, C_PTR - integer(HID_T), value :: group_id - type(C_PTR) :: name(*) - end subroutine get_groups_c - end interface - - ! Determine number of groups and allocate - n = get_num_groups(object_id) - allocate(names(n), names_(n), name_ptrs(n)) - - ! Set C pointers to beginning of each string - do i = 1, size(names) - name_ptrs(i) = c_loc(names_(i)) - end do - - ! Get names of groups and copy to Fortran strings - call get_groups_c(object_id, name_ptrs) - do i = 1, size(names) - names(i) = to_f_string(names_(i)) - end do - - end subroutine get_groups - -!=============================================================================== -! ATTRIBUTE_EXISTS checks to see if an attribute exists in the object -!=============================================================================== - - function attribute_exists(object_id, name) result(exists) - integer(HID_T), intent(in) :: object_id - character(*), intent(in) :: name ! name of group - logical :: exists - - interface - function attribute_exists_c(obj_id, name) result(exists) & - bind(C, name='attribute_exists') - import HID_T, C_CHAR, C_BOOL - integer(HID_T), value :: obj_id - character(kind=C_CHAR), intent(in) :: name(*) - logical(C_BOOL) :: exists - end function attribute_exists_c - end interface - - exists = attribute_exists_c(object_id, to_c_string(name)) - end function attribute_exists - -!=============================================================================== -! CHECK_GROUP Checks to see if a group exists in the object -!=============================================================================== - - function object_exists(object_id, name) result(exists) - integer(HID_T), intent(in) :: object_id - character(*), intent(in) :: name ! name of group - logical :: exists - - interface - function object_exists_c(obj_id, name) result(exists) & - bind(C, name='object_exists') - import HID_T, C_CHAR, C_BOOL - integer(HID_T), value :: obj_id - character(kind=C_CHAR), intent(in) :: name(*) - logical(C_BOOL) :: exists - end function object_exists_c - end interface - - ! Check if group exists - exists = object_exists_c(object_id, to_c_string(name)) - end function object_exists - -!=============================================================================== -! GET_DATASETS Gets a list of all the datasets in a given location. -!=============================================================================== - - subroutine get_datasets(object_id, names) - integer(HID_T), intent(in) :: object_id - character(len=150), allocatable, intent(out) :: names(:) - - integer :: i - integer(C_INT) :: n - character(len=150,kind=C_CHAR), target, allocatable :: names_(:) - type(C_PTR), allocatable :: name_ptrs(:) - - interface - function get_num_datasets(group_id) result(n) bind(C) - import HID_T, C_INT - integer(HID_T), value :: group_id - integer(C_INT) :: n - end function get_num_datasets - subroutine get_datasets_c(group_id, name) bind(C, name='get_datasets') - import HID_T, C_PTR - integer(HID_T), value :: group_id - type(C_PTR) :: name(*) - end subroutine get_datasets_c - end interface - - ! Determine number of datasets and allocate - n = get_num_datasets(object_id) - allocate(names(n), names_(n), name_ptrs(n)) - - ! Set C pointers to beginning of each string - do i = 1, size(names) - name_ptrs(i) = c_loc(names_(i)) - end do - - ! Get names of datasets and copy to Fortran strings - call get_datasets_c(object_id, name_ptrs) - do i = 1, size(names) - names(i) = to_f_string(names_(i)) - end do - - end subroutine get_datasets - -!=============================================================================== -! GET_NAME Obtains the name of the current group in group_id -!=============================================================================== - - function get_name(object_id) result(name) - integer(HID_T), intent(in) :: object_id - - character(150) :: name ! name of object - character(kind=C_CHAR) :: name_(150) - interface - subroutine get_name_c(obj_id, name) bind(C, name='get_name') - import HID_T, C_CHAR - integer(HID_T), value :: obj_id - character(kind=C_CHAR), intent(out) :: name(*) - end subroutine get_name_c - end interface - - call get_name_c(object_id, name_) - name = to_f_string(name_) - end function get_name - -!=============================================================================== -! OPEN_GROUP opens an existing HDF5 group -!=============================================================================== - - function open_group(group_id, name) result(newgroup_id) - integer(HID_T), intent(in) :: group_id - character(*), intent(in) :: name ! name of group - integer(HID_T) :: newgroup_id - - interface - function open_group_c(group_id, name) result(newgroup_id) & - bind(C, name='open_group') - import HID_T, C_CHAR - integer(HID_T), value :: group_id - character(kind=C_CHAR), intent(in) :: name(*) - integer(HID_T) :: newgroup_id - end function open_group_c - end interface - - newgroup_id = open_group_c(group_id, to_c_string(name)) - end function open_group - -!=============================================================================== -! CREATE_GROUP creates a new HDF5 group -!=============================================================================== - - function create_group(group_id, name) result(newgroup_id) - integer(HID_T), intent(in) :: group_id - character(*), intent(in) :: name ! name of group - integer(HID_T) :: newgroup_id - - interface - function create_group_c(group_id, name) result(newgroup_id) & - bind(C, name='create_group') - import HID_T, C_CHAR - integer(HID_T), value :: group_id - character(kind=C_CHAR), intent(in) :: name(*) - integer(HID_T) :: newgroup_id - end function create_group_c - end interface - - newgroup_id = create_group_c(group_id, to_c_string(name)) - end function create_group - -!=============================================================================== -! CLOSE_GROUP closes HDF5 temp_group -!=============================================================================== - - subroutine close_group(group_id) - integer(HID_T), intent(inout) :: group_id - interface - subroutine close_group_c(group_id) bind(C, name='close_group') - import HID_T - integer(HID_T), value :: group_id - end subroutine close_group_c - end interface - - call close_group_c(group_id) - end subroutine close_group - -!=============================================================================== -! OPEN_DATASET opens an existing HDF5 dataset -!=============================================================================== - - function open_dataset(group_id, name) result(dataset_id) - integer(HID_T), intent(in) :: group_id - character(*), intent(in) :: name ! name of dataset - integer(HID_T) :: dataset_id - - interface - function open_dataset_c(group_id, name) result(dset_id) & - bind(C, name='open_dataset') - import HID_T, C_CHAR - integer(HID_T), value :: group_id - character(kind=C_CHAR), intent(in) :: name(*) - integer(HID_T) :: dset_id - end function open_dataset_c - end interface - - dataset_id = open_dataset_c(group_id, to_c_string(name)) - end function open_dataset - -!=============================================================================== -! CLOSE_DATASET closes an HDF5 dataset -!=============================================================================== - - subroutine close_dataset(dataset_id) - integer(HID_T), intent(inout) :: dataset_id - - interface - subroutine close_dataset_c(dset_id) bind(C, name='close_dataset') - import HID_T - integer(HID_T), value :: dset_id - end subroutine close_dataset_c - end interface - - call close_dataset_c(dataset_id) - end subroutine close_dataset - -!=============================================================================== -! WRITE_DOUBLE_ND writes double precision N-D array data -!=============================================================================== - - subroutine write_double_0D(group_id, name, buffer, indep) - integer(HID_T), intent(in) :: group_id - character(*), intent(in) :: name ! name for data - real(8), intent(in), target :: buffer ! data to write - logical, intent(in), optional :: indep ! independent I/O - - integer(HSIZE_T) :: dims(0) - logical(C_BOOL) :: indep_ - real(C_DOUBLE) :: buffer_(1) - - indep_ = .false. - if (present(indep)) indep_ = indep - buffer_(1) = buffer - - call write_double_c(group_id, 0, dims, to_c_string(name), buffer_, indep_) - end subroutine write_double_0D - - subroutine write_double_1D(group_id, name, buffer, indep) - integer(HID_T), intent(in) :: group_id - character(*), intent(in) :: name ! name of data - real(8), intent(in), target :: buffer(:) ! data to write - logical, intent(in), optional :: indep ! independent I/O - - integer(HSIZE_T) :: dims(1) - logical(C_BOOL) :: indep_ - - dims(1) = size(buffer) - indep_ = .false. - if (present(indep)) indep_ = indep - - call write_double_c(group_id, 1, dims, to_c_string(name), buffer, indep_) - end subroutine write_double_1D - - subroutine write_double_2D(group_id, name, buffer, indep) - integer(HID_T), intent(in) :: group_id - character(*), intent(in) :: name ! name of data - real(8), intent(in), target :: buffer(:,:) ! data to write - logical, intent(in), optional :: indep ! independent I/O - - integer(HSIZE_T) :: dims(2) - logical(C_BOOL) :: indep_ - - ! Reverse shape of array since it will be written from C - dims(1) = size(buffer, 2) - dims(2) = size(buffer, 1) - - indep_ = .false. - if (present(indep)) indep_ = indep - - call write_double_c(group_id, 2, dims, to_c_string(name), buffer, indep_) - end subroutine write_double_2D - - subroutine write_double_3D(group_id, name, buffer, indep) - integer(HID_T), intent(in) :: group_id - character(*), intent(in) :: name ! name of data - real(8), intent(in), target :: buffer(:,:,:) ! data to write - logical, intent(in), optional :: indep ! independent I/O - - integer(HSIZE_T) :: dims(3) - logical(C_BOOL) :: indep_ - - ! Reverse shape of array since it will be written from C - dims(1) = size(buffer, 3) - dims(2) = size(buffer, 2) - dims(3) = size(buffer, 1) - - indep_ = .false. - if (present(indep)) indep_ = indep - - call write_double_c(group_id, 3, dims, to_c_string(name), buffer, indep_) - end subroutine write_double_3D - - subroutine write_double_4D(group_id, name, buffer, indep) - integer(HID_T), intent(in) :: group_id - character(*), intent(in) :: name ! name of data - real(8), intent(in), target :: buffer(:,:,:,:) ! data to write - logical, intent(in), optional :: indep ! independent I/O - - integer(HSIZE_T) :: dims(4) - logical(C_BOOL) :: indep_ - - ! Reverse shape of array since it will be written from C - dims(1) = size(buffer, 4) - dims(2) = size(buffer, 3) - dims(3) = size(buffer, 2) - dims(4) = size(buffer, 1) - - indep_ = .false. - if (present(indep)) indep_ = indep - - call write_double_c(group_id, 4, dims, to_c_string(name), buffer, indep_) - end subroutine write_double_4D - -!=============================================================================== -! READ_DOUBLE_ND reads double precision N-D array data -!=============================================================================== - - subroutine read_double_0D(buffer, obj_id, name, indep) - real(8), target, intent(inout) :: buffer - integer(HID_T), intent(in) :: obj_id - character(*), optional, intent(in) :: name - logical, optional, intent(in) :: indep ! independent I/O - - real(C_DOUBLE) :: buffer_(1) - logical(C_BOOL) :: indep_ - character(kind=C_CHAR), target, allocatable :: name_(:) - - indep_ = .false. - if (present(indep)) indep_ = indep - - ! If 'name' argument is passed, obj_id is interpreted to be a group and - ! 'name' is the name of the dataset we should read from - if (present(name)) then - allocate(name_(len_trim(name) + 1)) - name_ = to_c_string(name) - call read_double_c(obj_id, c_loc(name_), buffer_, indep_) - else - call read_double_c(obj_id, C_NULL_PTR, buffer_, indep_) - end if - buffer = buffer_(1) - end subroutine read_double_0D - - subroutine read_double_1D(buffer, obj_id, name, indep) - real(8), target, intent(inout) :: buffer(:) - integer(HID_T), intent(in) :: obj_id - character(*), optional, intent(in) :: name - logical, optional, intent(in) :: indep ! independent I/O - - logical(C_BOOL) :: indep_ - character(kind=C_CHAR), target, allocatable :: name_(:) - - indep_ = .false. - if (present(indep)) indep_ = indep - - ! If 'name' argument is passed, obj_id is interpreted to be a group and - ! 'name' is the name of the dataset we should read from - if (present(name)) then - allocate(name_(len_trim(name) + 1)) - name_ = to_c_string(name) - call read_double_c(obj_id, c_loc(name_), buffer, indep_) - else - call read_double_c(obj_id, C_NULL_PTR, buffer, indep_) - end if - end subroutine read_double_1D - - subroutine read_double_2D(buffer, obj_id, name, indep) - real(8), target, intent(inout) :: buffer(:,:) - integer(HID_T), intent(in) :: obj_id - character(*), optional, intent(in) :: name - logical, optional, intent(in) :: indep ! independent I/O - - logical(C_BOOL) :: indep_ - character(kind=C_CHAR), target, allocatable :: name_(:) - - indep_ = .false. - if (present(indep)) indep_ = indep - - ! If 'name' argument is passed, obj_id is interpreted to be a group and - ! 'name' is the name of the dataset we should read from - if (present(name)) then - allocate(name_(len_trim(name) + 1)) - name_ = to_c_string(name) - call read_double_c(obj_id, c_loc(name_), buffer, indep_) - else - call read_double_c(obj_id, C_NULL_PTR, buffer, indep_) - end if - end subroutine read_double_2D - - subroutine read_double_3D(buffer, obj_id, name, indep) - real(8), target, intent(inout) :: buffer(:,:,:) - integer(HID_T), intent(in) :: obj_id - character(*), optional, intent(in) :: name - logical, optional, intent(in) :: indep ! independent I/O - - logical(C_BOOL) :: indep_ - character(kind=C_CHAR), target, allocatable :: name_(:) - - indep_ = .false. - if (present(indep)) indep_ = indep - - ! If 'name' argument is passed, obj_id is interpreted to be a group and - ! 'name' is the name of the dataset we should read from - if (present(name)) then - allocate(name_(len_trim(name) + 1)) - name_ = to_c_string(name) - call read_double_c(obj_id, c_loc(name_), buffer, indep_) - else - call read_double_c(obj_id, C_NULL_PTR, buffer, indep_) - end if - end subroutine read_double_3D - - subroutine read_double_4D(buffer, obj_id, name, indep) - real(8), target, intent(inout) :: buffer(:,:,:,:) - integer(HID_T), intent(in) :: obj_id - character(*), optional, intent(in) :: name - logical, optional, intent(in) :: indep ! independent I/O - - logical(C_BOOL) :: indep_ - character(kind=C_CHAR), target, allocatable :: name_(:) - - indep_ = .false. - if (present(indep)) indep_ = indep - - ! If 'name' argument is passed, obj_id is interpreted to be a group and - ! 'name' is the name of the dataset we should read from - if (present(name)) then - allocate(name_(len_trim(name) + 1)) - name_ = to_c_string(name) - call read_double_c(obj_id, c_loc(name_), buffer, indep_) - else - call read_double_c(obj_id, C_NULL_PTR, buffer, indep_) - end if - end subroutine read_double_4D - -!=============================================================================== -! WRITE_INTEGER_ND writes integer precision N-D array data -!=============================================================================== - - subroutine write_integer_0D(group_id, name, buffer, indep) - integer(HID_T), intent(in) :: group_id - character(*), intent(in) :: name ! name for data - integer, intent(in), target :: buffer ! data to write - logical, intent(in), optional :: indep ! independent I/O - - integer(HSIZE_T) :: dims(0) - logical(C_BOOL) :: indep_ - integer(C_INT) :: buffer_(1) - - indep_ = .false. - if (present(indep)) indep_ = indep - buffer_(1) = buffer - - call write_int_c(group_id, 0, dims, to_c_string(name), buffer_, indep_) - end subroutine write_integer_0D - - subroutine write_integer_1D(group_id, name, buffer, indep) - integer(HID_T), intent(in) :: group_id - character(*), intent(in) :: name ! name of data - integer, intent(in), target :: buffer(:) ! data to write - logical, intent(in), optional :: indep ! independent I/O - - integer(HSIZE_T) :: dims(1) - logical(C_BOOL) :: indep_ - - dims(1) = size(buffer) - indep_ = .false. - if (present(indep)) indep_ = indep - - call write_int_c(group_id, 1, dims, to_c_string(name), buffer, indep_) - end subroutine write_integer_1D - - subroutine write_integer_2D(group_id, name, buffer, indep) - integer(HID_T), intent(in) :: group_id - character(*), intent(in) :: name ! name of data - integer, intent(in), target :: buffer(:,:) ! data to write - logical, intent(in), optional :: indep ! independent I/O - - integer(HSIZE_T) :: dims(2) - logical(C_BOOL) :: indep_ - - ! Reverse shape of array since it will be written from C - dims(1) = size(buffer, 2) - dims(2) = size(buffer, 1) - - indep_ = .false. - if (present(indep)) indep_ = indep - - call write_int_c(group_id, 2, dims, to_c_string(name), buffer, indep_) - end subroutine write_integer_2D - - subroutine write_integer_3D(group_id, name, buffer, indep) - integer(HID_T), intent(in) :: group_id - character(*), intent(in) :: name ! name of data - integer, intent(in), target :: buffer(:,:,:) ! data to write - logical, intent(in), optional :: indep ! independent I/O - - integer(HSIZE_T) :: dims(3) - logical(C_BOOL) :: indep_ - - ! Reverse shape of array since it will be written from C - dims(1) = size(buffer, 3) - dims(2) = size(buffer, 2) - dims(3) = size(buffer, 1) - - indep_ = .false. - if (present(indep)) indep_ = indep - - call write_int_c(group_id, 3, dims, to_c_string(name), buffer, indep_) - end subroutine write_integer_3D - - subroutine write_integer_4D(group_id, name, buffer, indep) - integer(HID_T), intent(in) :: group_id - character(*), intent(in) :: name ! name of data - integer, intent(in), target :: buffer(:,:,:,:) ! data to write - logical, intent(in), optional :: indep ! independent I/O - - integer(HSIZE_T) :: dims(4) - logical(C_BOOL) :: indep_ - - ! Reverse shape of array since it will be written from C - dims(1) = size(buffer, 4) - dims(2) = size(buffer, 3) - dims(3) = size(buffer, 2) - dims(4) = size(buffer, 1) - - indep_ = .false. - if (present(indep)) indep_ = indep - - call write_int_c(group_id, 3, dims, to_c_string(name), buffer, indep_) - end subroutine write_integer_4D - -!=============================================================================== -! READ_INTEGER_ND reads integer precision N-D array data -!=============================================================================== - - subroutine read_integer_0D(buffer, obj_id, name, indep) - integer, target, intent(inout) :: buffer - integer(HID_T), intent(in) :: obj_id - character(*), optional, intent(in) :: name - logical, optional, intent(in) :: indep ! independent I/O - - integer(C_INT) :: buffer_(1) - logical(C_BOOL) :: indep_ - character(kind=C_CHAR), target, allocatable :: name_(:) - - indep_ = .false. - if (present(indep)) indep_ = indep - - ! If 'name' argument is passed, obj_id is interpreted to be a group and - ! 'name' is the name of the dataset we should read from - if (present(name)) then - allocate(name_(len_trim(name) + 1)) - name_ = to_c_string(name) - call read_int_c(obj_id, c_loc(name_), buffer_, indep_) - else - call read_int_c(obj_id, C_NULL_PTR, buffer_, indep_) - end if - buffer = buffer_(1) - end subroutine read_integer_0D - - subroutine read_integer_1D(buffer, obj_id, name, indep) - integer, target, intent(inout) :: buffer(:) - integer(HID_T), intent(in) :: obj_id - character(*), optional, intent(in) :: name - logical, optional, intent(in) :: indep ! independent I/O - - logical(C_BOOL) :: indep_ - character(kind=C_CHAR), target, allocatable :: name_(:) - - indep_ = .false. - if (present(indep)) indep_ = indep - - ! If 'name' argument is passed, obj_id is interpreted to be a group and - ! 'name' is the name of the dataset we should read from - if (present(name)) then - allocate(name_(len_trim(name) + 1)) - name_ = to_c_string(name) - call read_int_c(obj_id, c_loc(name_), buffer, indep_) - else - call read_int_c(obj_id, C_NULL_PTR, buffer, indep_) - end if - end subroutine read_integer_1D - - subroutine read_integer_2D(buffer, obj_id, name, indep) - integer, target, intent(inout) :: buffer(:,:) - integer(HID_T), intent(in) :: obj_id - character(*), optional, intent(in) :: name - logical, optional, intent(in) :: indep ! independent I/O - - logical(C_BOOL) :: indep_ - character(kind=C_CHAR), target, allocatable :: name_(:) - - indep_ = .false. - if (present(indep)) indep_ = indep - - ! If 'name' argument is passed, obj_id is interpreted to be a group and - ! 'name' is the name of the dataset we should read from - if (present(name)) then - allocate(name_(len_trim(name) + 1)) - name_ = to_c_string(name) - call read_int_c(obj_id, c_loc(name_), buffer, indep_) - else - call read_int_c(obj_id, C_NULL_PTR, buffer, indep_) - end if - end subroutine read_integer_2D - - subroutine read_integer_3D(buffer, obj_id, name, indep) - integer, target, intent(inout) :: buffer(:,:,:) - integer(HID_T), intent(in) :: obj_id - character(*), optional, intent(in) :: name - logical, optional, intent(in) :: indep ! independent I/O - - logical(C_BOOL) :: indep_ - character(kind=C_CHAR), target, allocatable :: name_(:) - - indep_ = .false. - if (present(indep)) indep_ = indep - - ! If 'name' argument is passed, obj_id is interpreted to be a group and - ! 'name' is the name of the dataset we should read from - if (present(name)) then - allocate(name_(len_trim(name) + 1)) - name_ = to_c_string(name) - call read_int_c(obj_id, c_loc(name_), buffer, indep_) - else - call read_int_c(obj_id, C_NULL_PTR, buffer, indep_) - end if - end subroutine read_integer_3D - - subroutine read_integer_4D(buffer, obj_id, name, indep) - integer, target, intent(inout) :: buffer(:,:,:,:) - integer(HID_T), intent(in) :: obj_id - character(*), optional, intent(in) :: name - logical, optional, intent(in) :: indep ! independent I/O - - logical(C_BOOL) :: indep_ - character(kind=C_CHAR), target, allocatable :: name_(:) - - indep_ = .false. - if (present(indep)) indep_ = indep - - ! If 'name' argument is passed, obj_id is interpreted to be a group and - ! 'name' is the name of the dataset we should read from - if (present(name)) then - allocate(name_(len_trim(name) + 1)) - name_ = to_c_string(name) - call read_int_c(obj_id, c_loc(name_), buffer, indep_) - else - call read_int_c(obj_id, C_NULL_PTR, buffer, indep_) - end if - end subroutine read_integer_4D - -!=============================================================================== -! WRITE_LONG writes long integer scalar data -!=============================================================================== - - subroutine write_long(group_id, name, buffer, indep) - integer(HID_T), intent(in) :: group_id - character(*), intent(in) :: name ! name for data - integer(8), intent(in), target :: buffer ! data to write - logical, intent(in), optional :: indep ! independent I/O - - integer(HSIZE_T) :: dims(0) - logical(C_BOOL) :: indep_ - integer(C_LONG_LONG) :: buffer_(1) - - indep_ = .false. - if (present(indep)) indep_ = indep - buffer_(1) = buffer - - call write_llong_c(group_id, 0, dims, to_c_string(name), buffer_, indep_) - end subroutine write_long - -!=============================================================================== -! READ_LONG reads long integer scalar data -!=============================================================================== - - subroutine read_long(buffer, obj_id, name, indep) - integer(8), target, intent(inout) :: buffer - integer(HID_T), intent(in) :: obj_id - character(*), optional, intent(in) :: name - logical, optional, intent(in) :: indep ! independent I/O - - integer(C_LONG_LONG) :: buffer_(1) - logical(C_BOOL) :: indep_ - character(kind=C_CHAR), target, allocatable :: name_(:) - - indep_ = .false. - if (present(indep)) indep_ = indep - - ! If 'name' argument is passed, obj_id is interpreted to be a group and - ! 'name' is the name of the dataset we should read from - if (present(name)) then - allocate(name_(len_trim(name) + 1)) - name_ = to_c_string(name) - call read_llong_c(obj_id, c_loc(name_), buffer_, indep_) - else - call read_llong_c(obj_id, C_NULL_PTR, buffer_, indep_) - end if - buffer = buffer_(1) - end subroutine read_long - -!=============================================================================== -! WRITE_STRING writes string data -!=============================================================================== - - subroutine write_string(group_id, name, buffer, indep) - integer(HID_T), intent(in) :: group_id - character(*), intent(in) :: name ! name for data - character(*), intent(in), target :: buffer ! read data to here - logical, intent(in), optional :: indep ! independent I/O - - integer(HSIZE_T) :: dims(0) - integer(C_SIZE_T) :: slen - logical(C_BOOL) :: indep_ - - indep_ = .false. - if (present(indep)) indep_ = indep - slen = len_trim(buffer) - - call write_string_c(group_id, 0, dims, slen, to_c_string(name), & - to_c_string(buffer), indep_) - end subroutine write_string - -!=============================================================================== -! READ_STRING reads string data -!=============================================================================== - - subroutine read_string(buffer, obj_id, name, indep) - character(*), target, intent(inout) :: buffer - integer(HID_T), intent(in) :: obj_id - character(*), optional, intent(in) :: name - logical, optional, intent(in) :: indep ! independent I/O - - integer(HID_T) :: dset_id - integer(C_SIZE_T) :: i, n - logical(C_BOOL) :: indep_ - character(kind=C_CHAR), allocatable, target :: buffer_(:) - - if (present(name)) then - dset_id = open_dataset(obj_id, name) - else - dset_id = obj_id - end if - - ! Allocate a C char array to get string - n = dataset_typesize(dset_id) - allocate(buffer_(n)) - - indep_ = .false. - if (present(indep)) indep_ = indep - call read_string_c(dset_id, C_NULL_PTR, n, buffer_, indep_) - - buffer = '' - do i = 1, n - if (buffer_(i) == C_NULL_CHAR) cycle - buffer(i:i) = buffer_(i) - end do - - call close_dataset(dset_id) - end subroutine read_string - -!=============================================================================== -! WRITE_STRING_1D writes string 1-D array data -!=============================================================================== - - subroutine write_string_1D(group_id, name, buffer, indep) - integer(HID_T), intent(in) :: group_id - character(*), intent(in) :: name ! name for data - character(*), intent(in), target :: buffer(:) ! read data to here - logical, intent(in), optional :: indep ! independent I/O - - integer(HSIZE_T) :: i - integer(HSIZE_T) :: dims(1) - integer(C_SIZE_T) :: m, n - logical(C_BOOL) :: indep_ - character(kind=C_CHAR), allocatable :: buffer_(:) - - indep_ = .false. - if (present(indep)) indep_ = indep - - ! Copy array of characters into an array of C chars with the right memory - ! layout - dims(1) = size(buffer) - m = maxval(len_trim(buffer)) + 1 - allocate(buffer_(dims(1)*m)) - do i = 0, dims(1) - 1 - n = len_trim(buffer(i+1)) + 1 - buffer_(i*m+1 : i*m+n) = to_c_string(buffer(i+1)) - if (n < m) buffer_(i*m+n : i*m+m) = C_NULL_CHAR - end do - - call write_string_c(group_id, 1, dims, m, to_c_string(name), & - buffer_, indep_) - end subroutine write_string_1D - -!=============================================================================== -! READ_STRING_1D reads string 1-D array data -!=============================================================================== - - subroutine read_string_1D(buffer, obj_id, name, indep) - character(*), target, intent(inout) :: buffer(:) - integer(HID_T), intent(in) :: obj_id - character(*), optional, intent(in) :: name - logical, optional, intent(in) :: indep ! independent I/O - - integer(HID_T) :: dset_id - integer(C_SIZE_T) :: i, j, k, n, m - logical(C_BOOL) :: indep_ - character(kind=C_CHAR), allocatable, target :: buffer_(:) - - if (present(name)) then - dset_id = open_dataset(obj_id, name) - else - dset_id = obj_id - end if - - ! Allocate a C char array to get strings - n = dataset_typesize(dset_id) - m = size(buffer) - allocate(buffer_(n*m)) - - indep_ = .false. - if (present(indep)) indep_ = indep - call read_string_c(dset_id, C_NULL_PTR, n, buffer_, indep_) - - ! Convert null-terminated C strings into Fortran strings - do i = 1, m - buffer(i) = '' - do j = 1, n - k = (i-1)*n + j - if (buffer_(k) == C_NULL_CHAR) exit - buffer(i)(j:j) = buffer_(k) - end do - end do - - call close_dataset(dset_id) - end subroutine read_string_1D - -!=============================================================================== -! WRITE_ATTRIBUTE_STRING -!=============================================================================== - - subroutine write_attribute_string(obj_id, name, buffer) - integer(HID_T), intent(in) :: obj_id ! object to write attribute to - character(*), intent(in) :: name ! name of attribute - character(*), intent(in), target :: buffer ! string to write - - - call write_attr_string_c(obj_id, to_c_string(name), to_c_string(buffer)) - end subroutine write_attribute_string - - subroutine read_attribute_double(buffer, obj_id, name) - real(8), intent(inout), target :: buffer - integer(HID_T), intent(in) :: obj_id - character(*), intent(in) :: name - - real(C_DOUBLE) :: buffer_(1) - - call read_attr_double_c(obj_id, to_c_string(name), buffer_) - buffer = buffer_(1) - end subroutine read_attribute_double - - subroutine write_attribute_double(obj_id, name, buffer) - integer(HID_T), intent(in) :: obj_id - character(*), intent(in) :: name - real(8), intent(in), target :: buffer - - integer(HSIZE_T) :: dims(0) - real(C_DOUBLE) :: buffer_(1) - - buffer_(1) = buffer - call write_attr_double_c(obj_id, 0, dims, to_c_string(name), buffer_) - end subroutine write_attribute_double - - subroutine read_attribute_double_1D(buffer, obj_id, name) - real(8), target, allocatable, intent(inout) :: buffer(:) - integer(HID_T), intent(in) :: obj_id - character(*), intent(in) :: name - - integer(HSIZE_T) :: dims(1) - - if (.not. allocated(buffer)) then - call get_shape_attr(obj_id, to_c_string(name), dims) - allocate(buffer(dims(1))) - end if - - call read_attr_double_c(obj_id, to_c_string(name), buffer) - end subroutine read_attribute_double_1D - - subroutine write_attribute_double_1D(obj_id, name, buffer) - integer(HID_T), intent(in) :: obj_id - character(*), intent(in) :: name - real(8), target, intent(in) :: buffer(:) - - integer(HSIZE_T) :: dims(1) - - dims(1) = size(buffer) - call write_attr_double_c(obj_id, 1, dims, to_c_string(name), buffer) - end subroutine write_attribute_double_1D - - subroutine read_attribute_double_2D(buffer, obj_id, name) - real(8), target, allocatable, intent(inout) :: buffer(:,:) - integer(HID_T), intent(in) :: obj_id - character(*), intent(in) :: name - - integer(HSIZE_T) :: dims(2) - - if (.not. allocated(buffer)) then - call get_shape_attr(obj_id, to_c_string(name), dims) - allocate(buffer(dims(2), dims(1))) - end if - - call read_attr_double_c(obj_id, to_c_string(name), buffer) - end subroutine read_attribute_double_2D - - subroutine read_attribute_integer(buffer, obj_id, name) - integer, intent(inout), target :: buffer - integer(HID_T), intent(in) :: obj_id - character(*), intent(in) :: name - - integer(C_INT) :: buffer_(1) - - call read_attr_int_c(obj_id, to_c_string(name), buffer_) - buffer = buffer_(1) - end subroutine read_attribute_integer - - subroutine write_attribute_integer(obj_id, name, buffer) - integer(HID_T), intent(in) :: obj_id - character(*), intent(in) :: name - integer, intent(in), target :: buffer - - integer(HSIZE_T) :: dims(0) - integer(C_INT) :: buffer_(1) - - buffer_(1) = buffer - call write_attr_int_c(obj_id, 0, dims, to_c_string(name), buffer_) - end subroutine write_attribute_integer - - subroutine read_attribute_integer_1D(buffer, obj_id, name) - integer, target, allocatable, intent(inout) :: buffer(:) - integer(HID_T), intent(in) :: obj_id - character(*), intent(in) :: name - - integer(HSIZE_T) :: dims(1) - - if (.not. allocated(buffer)) then - call get_shape_attr(obj_id, to_c_string(name), dims) - allocate(buffer(dims(1))) - end if - - call read_attr_int_c(obj_id, to_c_string(name), buffer) - end subroutine read_attribute_integer_1D - - subroutine write_attribute_integer_1D(obj_id, name, buffer) - integer(HID_T), intent(in) :: obj_id - character(*), intent(in) :: name - integer, target, intent(in) :: buffer(:) - - integer(HSIZE_T) :: dims(1) - - dims(1) = size(buffer) - call write_attr_int_c(obj_id, 1, dims, to_c_string(name), buffer) - end subroutine write_attribute_integer_1D - - subroutine read_attribute_integer_2D(buffer, obj_id, name) - integer, target, allocatable, intent(inout) :: buffer(:,:) - integer(HID_T), intent(in) :: obj_id - character(*), intent(in) :: name - - integer(HSIZE_T) :: dims(2) - - if (.not. allocated(buffer)) then - call get_shape_attr(obj_id, to_c_string(name), dims) - allocate(buffer(dims(2), dims(1))) - end if - - call read_attr_int_c(obj_id, to_c_string(name), buffer) - end subroutine read_attribute_integer_2D - - subroutine read_attribute_string(buffer, obj_id, name) - character(*), intent(inout) :: buffer ! read data to here - integer(HID_T), intent(in) :: obj_id - character(*), intent(in) :: name ! name for data - - integer(C_SIZE_T) :: i, n - character(kind=C_CHAR), allocatable, target :: buffer_(:) - - ! Allocate a C char array to get string - n = attribute_typesize(obj_id, to_c_string(name)) - allocate(buffer_(n)) - - ! Read attribute - call read_attr_string_c(obj_id, to_c_string(name), n, buffer_) - - ! Copy back to Fortran string - buffer = '' - do i = 1, n - if (buffer_(i) == C_NULL_CHAR) cycle - buffer(i:i) = buffer_(i) - end do - end subroutine read_attribute_string - - subroutine read_attribute_string_1D(buffer, obj_id, name) - character(*), target, allocatable, intent(inout) :: buffer(:) - integer(HID_T), intent(in) :: obj_id - character(*), intent(in) :: name - - integer(C_SIZE_T) :: i, j, k, n, m - integer(HSIZE_T) :: dims(1) - character(kind=C_CHAR), allocatable, target :: buffer_(:) - - if (.not. allocated(buffer)) then - call get_shape_attr(obj_id, to_c_string(name), dims) - allocate(buffer(dims(1))) - end if - - ! Allocate a C char array to get strings - n = attribute_typesize(obj_id, to_c_string(name)) - m = size(buffer) - allocate(buffer_(n*m)) - - ! Read attribute - call read_attr_string_c(obj_id, to_c_string(name), n, buffer_) - - ! Convert null-terminated C strings into Fortran strings - do i = 1, m - buffer(i) = '' - do j = 1, n - k = (i-1)*n + j - if (buffer_(k) == C_NULL_CHAR) exit - buffer(i)(j:j) = buffer_(k) - end do - end do - end subroutine read_attribute_string_1D - - subroutine read_attribute_logical(buffer, obj_id, name) - logical, intent(inout), target :: buffer - integer(HID_T), intent(in) :: obj_id - character(*), intent(in) :: name - - integer :: tmp - - call read_attribute_integer(tmp, obj_id, name) - buffer = (tmp /= 0) - end subroutine read_attribute_logical - - subroutine get_shape(obj_id, dims) - integer(HID_T), intent(in) :: obj_id - integer(HSIZE_T), intent(out) :: dims(:) - - integer :: i - integer(HSIZE_T) :: dims_c(size(dims)) - - call get_shape_c(obj_id, dims_c) - do i = 1, size(dims) - dims(i) = dims_c(size(dims) - i + 1) - end do - end subroutine get_shape - - subroutine get_ndims(obj_id, ndims) - integer(HID_T), intent(in) :: obj_id - integer, intent(out) :: ndims - - interface - function dataset_ndims(dset) result(ndims) bind(C) - import HID_T, C_INT - integer(HID_T), value :: dset - integer(C_INT) :: ndims - end function dataset_ndims - end interface - - ndims = dataset_ndims(obj_id) - end subroutine get_ndims - -!=============================================================================== -! READ_COMPLEX_2D reads double precision complex 2-D array data as output by -! the h5py HDF5 python module. -!=============================================================================== - - subroutine read_complex_2D(buffer, obj_id, name, indep) - complex(C_DOUBLE_COMPLEX), target, intent(inout) :: buffer(:,:) - integer(HID_T), intent(in) :: obj_id - character(*), optional, intent(in) :: name - logical, optional, intent(in) :: indep ! independent I/O - - logical(C_BOOL) :: indep_ - character(kind=C_CHAR), target, allocatable :: name_(:) - - indep_ = .false. - if (present(indep)) indep_ = indep - - ! If 'name' argument is passed, obj_id is interpreted to be a group and - ! 'name' is the name of the dataset we should read from - if (present(name)) then - allocate(name_(len_trim(name) + 1)) - name_ = to_c_string(name) - call read_complex_c(obj_id, c_loc(name_), buffer, indep_) - else - call read_complex_c(obj_id, C_NULL_PTR, buffer, indep_) - end if - end subroutine read_complex_2D - -end module hdf5_interface diff --git a/src/initialize.F90 b/src/initialize.F90 deleted file mode 100644 index 4cef58a814..0000000000 --- a/src/initialize.F90 +++ /dev/null @@ -1,44 +0,0 @@ -module initialize - - use, intrinsic :: ISO_C_BINDING - - use settings - use string, only: to_f_string - - implicit none - - interface - function path_input_c() result(ptr) bind(C) - import C_PTR - type(C_PTR) :: ptr - end function - end interface - -contains - -!=============================================================================== -! READ_COMMAND_LINE reads all parameters from the command line -!=============================================================================== - - subroutine read_command_line() bind(C) - ! Arguments were already read on C++ side (initialize.cpp). Here we just - ! convert the C-style strings to Fortran style - - character(kind=C_CHAR), pointer :: string(:) - interface - function is_null(ptr) result(x) bind(C) - import C_PTR, C_BOOL - type(C_PTR), value :: ptr - logical(C_BOOL) :: x - end function is_null - end interface - - if (.not. is_null(path_input_c())) then - call c_f_pointer(path_input_c(), string, [255]) - path_input = to_f_string(string) - else - path_input = '' - end if - end subroutine read_command_line - -end module initialize diff --git a/src/initialize.cpp b/src/initialize.cpp index 553ad5d3db..4bb4817ea0 100644 --- a/src/initialize.cpp +++ b/src/initialize.cpp @@ -32,13 +32,6 @@ #include "openmc/thermal.h" #include "openmc/timer.h" -// data/functions from Fortran side -extern "C" void read_command_line(); - -// Paths to various files -extern "C" { - bool is_null(void* ptr) {return !ptr;} -} int openmc_init(int argc, char* argv[], const void* intracomm) { @@ -73,9 +66,6 @@ int openmc_init(int argc, char* argv[], const void* intracomm) } #endif - // Read command line arguments - read_command_line(); - // Initialize random number generator -- if the user specifies a seed, it // will be re-initialized later openmc_set_seed(DEFAULT_SEED); @@ -107,11 +97,7 @@ void initialize_mpi(MPI_Comm intracomm) // Determine number of processes and rank for each MPI_Comm_size(intracomm, &mpi::n_procs); MPI_Comm_rank(intracomm, &mpi::rank); - - // Set variable for Fortran side - openmc_n_procs = mpi::n_procs; - openmc_rank = mpi::rank; - openmc_master = mpi::master = (mpi::rank == 0); + mpi::master = (mpi::rank == 0); // Create bank datatype Bank b; diff --git a/src/material_header.F90 b/src/material_header.F90 deleted file mode 100644 index dc1e689448..0000000000 --- a/src/material_header.F90 +++ /dev/null @@ -1,48 +0,0 @@ -module material_header - - use, intrinsic :: ISO_C_BINDING - - implicit none - - private - public :: material_id - public :: material_nuclide - public :: material_nuclide_size - public :: material_atom_density - public :: material_density_gpcc - - interface - function material_id(i_mat) bind(C) result(id) - import C_INT32_T - integer(C_INT32_T), value :: i_mat - integer(C_INT32_T) :: id - end function - - function material_nuclide(i_mat, idx) bind(C) result(nuc) - import C_INT32_T, C_INT - integer(C_INT32_T), value :: i_mat - integer(C_INT), value :: idx - integer(C_INT) :: nuc - end function - - function material_nuclide_size(i_mat) bind(C) result(n) - import C_INT32_T, C_INT - integer(C_INT32_T), value :: i_mat - integer(C_INT) :: n - end function - - function material_atom_density(i_mat, idx) bind(C) result(density) - import C_INT32_T, C_INT, C_DOUBLE - integer(C_INT32_T), value :: i_mat - integer(C_INT), value :: idx - real(C_DOUBLE) :: density - end function - - function material_density_gpcc(i_mat) bind(C) result(density) - import C_INT32_T, C_DOUBLE - integer(C_INT32_T), value :: i_mat - real(C_DOUBLE) :: density - end function - end interface - -end module material_header diff --git a/src/message_passing.F90 b/src/message_passing.F90 deleted file mode 100644 index 37d2034475..0000000000 --- a/src/message_passing.F90 +++ /dev/null @@ -1,13 +0,0 @@ -module message_passing - - use, intrinsic :: ISO_C_BINDING - - ! The defaults set here for the number of processors, rank, and master and are - ! for when MPI is not being used at all, i.e. a serial run. In this case, these - ! variables are still used at times. - - integer(C_INT), bind(C, name='openmc_n_procs') :: n_procs = 1 ! number of processes - integer(C_INT), bind(C, name='openmc_rank') :: rank = 0 ! rank of process - logical(C_BOOL), bind(C, name='openmc_master') :: master = .true. ! master process? - -end module message_passing diff --git a/src/message_passing.cpp b/src/message_passing.cpp index 8d8779cca2..278bf924d3 100644 --- a/src/message_passing.cpp +++ b/src/message_passing.cpp @@ -12,24 +12,8 @@ MPI_Comm intracomm; MPI_Datatype bank; #endif +extern "C" bool openmc_master() { return mpi::master; } + } // namespace mpi -//============================================================================== -// Fortran compatibility functions -//============================================================================== - -#ifdef OPENMC_MPI -extern "C" void -send_int(void* buffer, int count, int dest, int tag) -{ - MPI_Send(buffer, count, MPI_INTEGER, dest, tag, mpi::intracomm); -} - -extern "C" void -recv_int(void* buffer, int count, int source, int tag) -{ - MPI_Recv(buffer, count, MPI_INTEGER, source, tag, mpi::intracomm, MPI_STATUS_IGNORE); -} -#endif - } // namespace openmc diff --git a/src/particle_header.F90 b/src/particle_header.F90 deleted file mode 100644 index 268fbb2857..0000000000 --- a/src/particle_header.F90 +++ /dev/null @@ -1,150 +0,0 @@ -module particle_header - - use, intrinsic :: ISO_C_BINDING - - use bank_header, only: Bank - use constants - use string, only: to_c_string - - implicit none - -!=============================================================================== -! LOCALCOORD describes the location of a particle local to a single -! universe. When the geometry consists of nested universes, a particle will have -! a list of coordinates in each level -!=============================================================================== - - type, bind(C) :: LocalCoord - ! Indices in various arrays for this level - integer(C_INT) :: cell = NONE - integer(C_INT) :: universe = NONE - integer(C_INT) :: lattice = NONE - integer(C_INT) :: lattice_x = NONE - integer(C_INT) :: lattice_y = NONE - integer(C_INT) :: lattice_z = NONE - - ! Particle position and direction for this level - real(C_DOUBLE) :: xyz(3) - real(C_DOUBLE) :: uvw(3) - - ! Is this level rotated? - logical(C_BOOL) :: rotated = .false. - end type LocalCoord - -!=============================================================================== -! PARTICLE describes the state of a particle being transported through the -! geometry -!=============================================================================== - - type, bind(C) :: Particle - ! Basic data - integer(C_INT64_T) :: id ! Unique ID - integer(C_INT) :: type ! Particle type (n, p, e, etc) - - ! Particle coordinates - integer(C_INT) :: n_coord ! number of current coordinates - integer(C_INT) :: cell_instance ! offset for distributed properties - type(LocalCoord) :: coord(MAX_COORD) ! coordinates for all levels - - ! Particle coordinates before crossing a surface - integer(C_INT) :: last_n_coord ! number of current coordinates - integer(C_INT) :: last_cell(MAX_COORD) ! coordinates for all levels - - ! Energy Data - real(C_DOUBLE) :: E ! post-collision energy - real(C_DOUBLE) :: last_E ! pre-collision energy - integer(C_INT) :: g ! post-collision energy group (MG only) - integer(C_INT) :: last_g ! pre-collision energy group (MG only) - - ! Other physical data - real(C_DOUBLE) :: wgt ! particle weight - real(C_DOUBLE) :: mu ! angle of scatter - logical(C_BOOL) :: alive ! is particle alive? - - ! Pre-collision physical data - real(C_DOUBLE) :: last_xyz_current(3) ! coordinates of the last collision or - ! reflective/periodic surface crossing - ! for current tallies - real(C_DOUBLE) :: last_xyz(3) ! previous coordinates - real(C_DOUBLE) :: last_uvw(3) ! previous direction coordinates - real(C_DOUBLE) :: last_wgt ! pre-collision particle weight - real(C_DOUBLE) :: absorb_wgt ! weight absorbed for survival biasing - - ! What event last took place - logical(C_BOOL) :: fission ! did the particle cause implicit fission - integer(C_INT) :: event ! scatter, absorption - integer(C_INT) :: event_nuclide ! index in nuclides array - integer(C_INT) :: event_MT ! reaction MT - integer(C_INT) :: delayed_group ! delayed group - - ! Post-collision physical data - integer(C_INT) :: n_bank ! number of fission sites banked - real(C_DOUBLE) :: wgt_bank ! weight of fission sites banked - integer(C_INT) :: n_delayed_bank(MAX_DELAYED_GROUPS) ! number of delayed fission - ! sites banked - - ! Indices for various arrays - integer(C_INT) :: surface ! index for surface particle is on - integer(C_INT) :: cell_born ! index for cell particle was born in - integer(C_INT) :: material ! index for current material - integer(C_INT) :: last_material ! index for last material - - ! Temperature of the current cell - real(C_DOUBLE) :: sqrtkT ! sqrt(k_Boltzmann * temperature) in eV - real(C_DOUBLE) :: last_sqrtKT ! last temperature - - ! Statistical data - integer(C_INT) :: n_collision ! # of collisions - - ! Track output - logical(C_BOOL) :: write_track = .false. - - ! Secondary particles created - integer(C_INT64_T) :: n_secondary = 0 - type(Bank) :: secondary_bank(MAX_SECONDARY) - end type Particle - - interface - subroutine reset_coord(c) bind(C) - import LocalCoord - type(LocalCoord), intent(inout) :: c - end subroutine reset_coord - - subroutine particle_clear(p) bind(C) - import Particle - type(Particle), intent(inout) :: p - end subroutine particle_clear - - subroutine particle_initialize(p) bind(C) - import Particle - type(Particle), intent(inout) :: p - end subroutine particle_initialize - - subroutine particle_from_source(p, src) bind(C) - import Particle, Bank, C_DOUBLE - type(Particle), intent(inout) :: p - type(Bank), intent(in) :: src - end subroutine particle_from_source - - subroutine particle_mark_as_lost_c(p, message) bind(C, name='particle_mark_as_lost') - import Particle, C_CHAR - type(Particle), intent(in) :: p - character(kind=C_CHAR), intent(in) :: message(*) - end subroutine particle_mark_as_lost_c - - subroutine particle_write_restart(p) bind(C) - import Particle - type(Particle), intent(in) :: p - end subroutine particle_write_restart - end interface - -contains - - subroutine particle_mark_as_lost(this, message) - type(Particle), intent(inout) :: this - character(*) :: message - - call particle_mark_as_lost_c(this, to_c_string(message)) - end subroutine particle_mark_as_lost - -end module particle_header diff --git a/src/pugixml/pugixml_c.cpp b/src/pugixml/pugixml_c.cpp deleted file mode 100644 index 925ec6e814..0000000000 --- a/src/pugixml/pugixml_c.cpp +++ /dev/null @@ -1 +0,0 @@ -#include "pugixml_c.hpp" diff --git a/src/pugixml/pugixml_c.hpp b/src/pugixml/pugixml_c.hpp deleted file mode 100644 index 92e95edace..0000000000 --- a/src/pugixml/pugixml_c.hpp +++ /dev/null @@ -1,97 +0,0 @@ -#include - -#include "pugixml.hpp" - -using namespace pugi; - -extern "C" { - // xml_node functions - - const char* xml_node_name(xml_node_struct* node){ - return xml_node(node).name(); - } - - xml_node_struct* xml_node_child(xml_node_struct* node, char* name){ - return xml_node(node).child(name).internal_object(); - } - - xml_node_struct* xml_node_next_sibling(xml_node_struct* node, char* name){ - return xml_node(node).next_sibling(name).internal_object(); - } - - xml_attribute_struct* xml_node_attribute(xml_node_struct* node, char* name){ - return xml_node(node).attribute(name).internal_object(); - } - - const char* xml_node_child_value(xml_node_struct* node){ - return xml_node(node).child_value(); - } - - xml_node_struct* xml_node_text(xml_node_struct* node){ - return xml_node(node).internal_object(); - } - - // xml_attribute functions - - const char* xml_attribute_name(xml_attribute_struct* attribute){ - return xml_attribute(attribute).name(); - } - - const char* xml_attribute_value(xml_attribute_struct* attribute){ - return xml_attribute(attribute).value(); - } - - xml_attribute_struct* xml_attribute_next_attribute(xml_attribute_struct* attribute){ - return xml_attribute(attribute).next_attribute().internal_object(); - } - - bool xml_attribute_as_bool(xml_attribute_struct* attribute){ - return xml_attribute(attribute).as_bool(); - } - - int xml_attribute_as_int(xml_attribute_struct* attribute){ - return xml_attribute(attribute).as_int(); - } - - long long xml_attribute_as_llong(xml_attribute_struct* attribute){ - return xml_attribute(attribute).as_llong(); - } - - double xml_attribute_as_double(xml_attribute_struct* attribute){ - return xml_attribute(attribute).as_double(); - } - - // xml_text functions - - bool xml_text_as_bool(xml_node_struct* node){ - return xml_node(node).text().as_bool(); - } - - int xml_text_as_int(xml_node_struct* node){ - return xml_node(node).text().as_int(); - } - - long long xml_text_as_llong(xml_node_struct* node){ - return xml_node(node).text().as_llong(); - } - - double xml_text_as_double(xml_node_struct* node){ - return xml_node(node).text().as_double(); - } - - // xml_document functions - - xml_document* xml_document_load_file(char* filename){ - xml_document * doc = new xml_document(); - xml_parse_result result = doc->load_file(filename); - return doc; - } - - xml_node_struct* xml_document_document_element(xml_document* doc){ - return doc->document_element().internal_object(); - } - - void xml_document_clear(xml_document* doc){ - delete doc; - } -} diff --git a/src/pugixml/pugixml_f.F90 b/src/pugixml/pugixml_f.F90 deleted file mode 100644 index bb45b79c23..0000000000 --- a/src/pugixml/pugixml_f.F90 +++ /dev/null @@ -1,451 +0,0 @@ -module pugixml - - use, intrinsic :: ISO_C_BINDING - - implicit none - private - - interface - function strlen(str) result(sz) bind(C) - import C_PTR, C_SIZE_T - type(C_PTR), value :: str - integer(C_SIZE_T) :: sz - end function strlen - end interface - - !============================================================================= - ! XMLNode C interface and derived type - - interface - function xml_node_name(node) result(name) bind(C) - import C_PTR - type(C_PTR), value :: node - type(C_PTR) :: name - end function xml_node_name - - function xml_node_name_size(base) result(sz) bind(C) - import C_PTR, C_SIZE_T - type(C_PTR), value :: base - integer(C_SIZE_T) :: sz - end function xml_node_name_size - - function xml_node_child(node, name) result(child) bind(C) - import C_PTR - type(C_PTR), value :: node - type(C_PTR), value :: name - type(C_PTR) :: child - end function xml_node_child - - function xml_node_next_sibling(node, name) result(next) bind(C) - import C_PTR - type(C_PTR), value :: node - type(C_PTR), value :: name - type(C_PTR) :: next - end function xml_node_next_sibling - - function xml_node_attribute(node, name) result(attribute) bind(C) - import C_PTR - type(C_PTR), value :: node - type(C_PTR), value :: name - type(C_PTR) :: attribute - end function xml_node_attribute - - function xml_node_child_value(node) result(val) bind(C) - import C_PTR - type(C_PTR), value :: node - type(C_PTR) :: val - end function xml_node_child_value - - function xml_node_text(node) result(text) bind(C) - import C_PTR - type(C_PTR), value :: node - type(C_PTR) :: text - end function xml_node_text - end interface - - type :: XMLNode - type(C_PTR) :: ptr - contains - procedure :: name => xmlnode_name - procedure :: child => xmlnode_child - procedure :: next_sibling => xmlnode_next_sibling - procedure :: attribute => xmlnode_attribute - procedure :: child_value => xmlnode_child_value - procedure :: text => xmlnode_text - procedure :: associated => xmlnode_associated - end type XMLNode - - !============================================================================= - ! XMLAttribute C interface and derived type - - interface - function xml_attribute_name(attribute) result(name) bind(C) - import C_PTR - type(C_PTR), value :: attribute - type(C_PTR) :: name - end function xml_attribute_name - - function xml_attribute_name_size(base) result(sz) bind(C) - import C_PTR, C_SIZE_T - type(C_PTR), value :: base - integer(C_SIZE_T) :: sz - end function xml_attribute_name_size - - function xml_attribute_value(attribute) result(val) bind(C) - import C_PTR - type(C_PTR), value :: attribute - type(C_PTR) :: val - end function xml_attribute_value - - function xml_attribute_next_attribute(attribute) result(next) bind(C) - import C_PTR - type(C_PTR), value :: attribute - type(C_PTR) :: next - end function xml_attribute_next_attribute - - function xml_attribute_as_bool(attribute) result(x) bind(C) - import C_PTR, C_BOOL - type(C_PTR), value :: attribute - logical(C_BOOL) :: x - end function xml_attribute_as_bool - - function xml_attribute_as_int(attribute) result(x) bind(C) - import C_PTR, C_INT - type(C_PTR), value :: attribute - integer(C_INT) :: x - end function xml_attribute_as_int - - function xml_attribute_as_llong(attribute) result(x) bind(C) - import C_PTR, C_LONG_LONG - type(C_PTR), value :: attribute - integer(C_LONG_LONG) :: x - end function xml_attribute_as_llong - - function xml_attribute_as_double(attribute) result(x) bind(C) - import C_PTR, C_DOUBLE - type(C_PTR), value :: attribute - real(C_DOUBLE) :: x - end function xml_attribute_as_double - end interface - - type :: XMLAttribute - type(C_PTR) :: ptr - contains - procedure :: name => xmlattribute_name - procedure :: value => xmlattribute_value - procedure :: next_attribute => xmlattribute_next_attribute - procedure :: as_bool => xmlattribute_as_bool - procedure :: as_int => xmlattribute_as_int - procedure :: as_llong => xmlattribute_as_llong - procedure :: as_double => xmlattribute_as_double - procedure :: associated => xmlattribute_associated - end type XMLAttribute - - !============================================================================= - ! XMLText C interface and derived type - - interface - function xml_text_as_bool(text) result(x) bind(C) - import C_PTR, C_BOOL - type(C_PTR), value :: text - logical(C_BOOL) :: x - end function xml_text_as_bool - - function xml_text_as_int(text) result(x) bind(C) - import C_PTR, C_INT - type(C_PTR), value :: text - integer(C_INT) :: x - end function xml_text_as_int - - function xml_text_as_llong(text) result(x) bind(C) - import C_PTR, C_LONG_LONG - type(C_PTR), value :: text - integer(C_LONG_LONG) :: x - end function xml_text_as_llong - - function xml_text_as_double(text) result(x) bind(C) - import C_PTR, C_DOUBLE - type(C_PTR), value :: text - real(C_DOUBLE) :: x - end function xml_text_as_double - end interface - - type :: XMLText - type(C_PTR) :: ptr - contains - procedure :: as_bool => xmltext_as_bool - procedure :: as_int => xmltext_as_int - procedure :: as_llong => xmltext_as_llong - procedure :: as_double => xmltext_as_double - end type XMLText - - !============================================================================= - ! XMLDocument C interface and derived type - - interface - function xml_document_load_file(filename) result(doc) bind(C) - import C_PTR - type(C_PTR), value :: filename - type(C_PTR) :: doc - end function xml_document_load_file - - function xml_document_document_element(doc) result(node) bind(C) - import C_PTR - type(C_PTR), value :: doc - type(C_PTR) :: node - end function xml_document_document_element - - subroutine xml_document_clear(doc) bind(C) - import C_PTR - type(C_PTR), value :: doc - end subroutine xml_document_clear - end interface - - type, extends(XMLNode) :: XMLDocument - contains - procedure :: load_file => xmldocument_load_file - procedure :: document_element => xmldocument_document_element - procedure :: clear => xmldocument_clear - end type XMLDocument - - public :: XMLNode, XMLAttribute, XMLText, XMLDocument - -contains - - !============================================================================= - ! XMLNode Implementation - - function xmlnode_name(this) result(name) - class(XMLNode), intent(in) :: this - character(len=:, kind=C_CHAR), allocatable :: name - - character(kind=C_CHAR), pointer :: string(:) - integer(C_SIZE_T) :: size_string - integer(C_SIZE_T) :: i - type(C_PTR) :: name_ptr - - name_ptr = xml_node_name(this % ptr) - size_string = strlen(name_ptr) - call c_f_pointer(name_ptr, string, [size_string]) - allocate(character(len=size_string, kind=C_CHAR) :: name) - do i = 1, size_string - name(i:i) = string(i) - end do - end function xmlnode_name - - function xmlnode_child(this, name) result(child) - class(XMLNode), intent(in) :: this - character(len=*), optional :: name - type(XMLNode) :: child - - integer :: i, n - character(len=:, kind=C_CHAR), target, allocatable :: string - - if (present(name)) then - allocate(character(len=len_trim(name) + 1, kind=C_CHAR) :: string) - n = len_trim(name) - do i = 1, n - string(i:i) = name(i:i) - end do - string(n+1:n+1) = C_NULL_CHAR - child % ptr = xml_node_child(this % ptr, c_loc(string)) - else - child % ptr = xml_node_child(this % ptr, C_NULL_PTR) - end if - end function xmlnode_child - - function xmlnode_next_sibling(this, name) result(next) - class(XMLNode), intent(in) :: this - character(len=*), optional :: name - type(XMLNode) :: next - - integer :: i, n - character(len=:, kind=C_CHAR), target, allocatable :: string - - if (present(name)) then - allocate(character(len=len_trim(name) + 1, kind=C_CHAR) :: string) - n = len_trim(name) - do i = 1, n - string(i:i) = name(i:i) - end do - string(n+1:n+1) = C_NULL_CHAR - next % ptr = xml_node_next_sibling(this % ptr, c_loc(string)) - else - next % ptr = xml_node_next_sibling(this % ptr, C_NULL_PTR) - end if - end function xmlnode_next_sibling - - function xmlnode_attribute(this, name) result(attribute) - class(XMLNode), intent(in) :: this - character(len=*), intent(in) :: name - type(XMLAttribute) :: attribute - - integer :: i, n - character(kind=C_CHAR), target :: string(len_trim(name) + 1) - - n = len_trim(name) - do i = 1, n - string(i) = name(i:i) - end do - string(n+1) = C_NULL_CHAR - attribute % ptr = xml_node_attribute(this % ptr, c_loc(string)) - end function xmlnode_attribute - - function xmlnode_child_value(this) result(val) - class(XMLNode), intent(in) :: this - character(len=:, kind=C_CHAR), allocatable :: val - - character(kind=C_CHAR), pointer :: string(:) - integer(C_SIZE_T) :: size_string - integer(C_SIZE_T) :: i - type(C_PTR) :: text - - text = xml_node_child_value(this % ptr) - size_string = strlen(text) - call c_f_pointer(text, string, [size_string]) - allocate(character(len=size_string, kind=C_CHAR) :: val) - do i = 1, size_string - val(i:i) = string(i) - end do - end function xmlnode_child_value - - function xmlnode_text(this) result(text) - class(XMLNode), intent(in) :: this - type(XMLText) :: text - - text % ptr = xml_node_text(this % ptr) - end function xmlnode_text - - logical function xmlnode_associated(this) - class(XMLNode), intent(in) :: this - - xmlnode_associated = c_associated(this % ptr) - end function xmlnode_associated - - !============================================================================= - ! XMLAttribute Implementation - - function xmlattribute_name(this) result(name) - class(XMLAttribute), intent(in) :: this - character(len=:, kind=C_CHAR), allocatable :: name - - character(kind=C_CHAR), pointer :: string(:) - integer(C_SIZE_T) :: size_string - integer(C_SIZE_T) :: i - type(C_PTR) :: name_ptr - - name_ptr = xml_attribute_name(this % ptr) - size_string = strlen(name_ptr) - call c_f_pointer(name_ptr, string, [size_string]) - allocate(character(len=size_string, kind=C_CHAR) :: name) - do i = 1, size_string - name(i:i) = string(i) - end do - end function xmlattribute_name - - function xmlattribute_value(this) result(val) - class(XMLAttribute), intent(in) :: this - character(len=:, kind=C_CHAR), allocatable :: val - - character(kind=C_CHAR), pointer :: string(:) - integer(C_SIZE_T) :: size_string - integer(C_SIZE_T) :: i - type(C_PTR) :: val_ptr - - val_ptr = xml_attribute_value(this % ptr) - size_string = strlen(val_ptr) - call c_f_pointer(val_ptr, string, [size_string]) - allocate(character(len=size_string, kind=C_CHAR) :: val) - do i = 1, size_string - val(i:i) = string(i) - end do - end function xmlattribute_value - - function xmlattribute_next_attribute(this) result(next) - class(XMLAttribute), intent(in) :: this - type(XMLAttribute) :: next - - next % ptr = xml_attribute_next_attribute(this % ptr) - end function xmlattribute_next_attribute - - logical(C_BOOL) function xmlattribute_as_bool(this) - class(XMLAttribute), intent(in) :: this - xmlattribute_as_bool = xml_attribute_as_bool(this % ptr) - end function xmlattribute_as_bool - - integer(C_INT) function xmlattribute_as_int(this) - class(XMLAttribute), intent(in) :: this - xmlattribute_as_int = xml_attribute_as_int(this % ptr) - end function xmlattribute_as_int - - integer(C_LONG_LONG) function xmlattribute_as_llong(this) - class(XMLAttribute), intent(in) :: this - xmlattribute_as_llong = xml_attribute_as_llong(this % ptr) - end function xmlattribute_as_llong - - real(C_DOUBLE) function xmlattribute_as_double(this) - class(XMLAttribute), intent(in) :: this - xmlattribute_as_double = xml_attribute_as_double(this % ptr) - end function xmlattribute_as_double - - logical function xmlattribute_associated(this) - class(XMLAttribute), intent(in) :: this - - xmlattribute_associated = c_associated(this % ptr) - end function xmlattribute_associated - - !============================================================================= - ! XMLText Implementation - - logical(C_BOOL) function xmltext_as_bool(this) - class(XMLText), intent(in) :: this - xmltext_as_bool = xml_text_as_bool(this % ptr) - end function xmltext_as_bool - - integer(C_INT) function xmltext_as_int(this) - class(XMLText), intent(in) :: this - xmltext_as_int = xml_text_as_int(this % ptr) - end function xmltext_as_int - - integer(C_LONG_LONG) function xmltext_as_llong(this) - class(XMLText), intent(in) :: this - xmltext_as_llong = xml_text_as_llong(this % ptr) - end function xmltext_as_llong - - real(C_DOUBLE) function xmltext_as_double(this) - class(XMLText), intent(in) :: this - xmltext_as_double = xml_text_as_double(this % ptr) - end function xmltext_as_double - - !============================================================================= - ! XMLDocument Implementation - - subroutine xmldocument_load_file(this, filename) - class(XMLDocument), intent(inout) :: this - character(*), intent(in) :: filename - - integer :: i, n - character(kind=C_CHAR), target :: string(len_trim(filename) + 1) - - n = len_trim(filename) - do i = 1, n - string(i) = filename(i:i) - end do - string(n+1) = C_NULL_CHAR - this % ptr = xml_document_load_file(c_loc(string)) - end subroutine xmldocument_load_file - - function xmldocument_document_element(this) result(node) - class(XMLDocument), intent(in) :: this - type(XMLNode) :: node - - node % ptr = xml_document_document_element(this % ptr) - end function xmldocument_document_element - - subroutine xmldocument_clear(this) - class(XMLDocument), intent(inout) :: this - - call xml_document_clear(this % ptr) - end subroutine xmldocument_clear - -end module pugixml diff --git a/src/random_lcg.F90 b/src/random_lcg.F90 deleted file mode 100644 index 84dac0a1b9..0000000000 --- a/src/random_lcg.F90 +++ /dev/null @@ -1,26 +0,0 @@ -module random_lcg - - use, intrinsic :: ISO_C_BINDING - - implicit none - - interface - function prn() result(pseudo_rn) bind(C) - use ISO_C_BINDING - implicit none - real(C_DOUBLE) :: pseudo_rn - end function prn - - subroutine set_particle_seed(id) bind(C) - use ISO_C_BINDING - implicit none - integer(C_INT64_T), value :: id - end subroutine set_particle_seed - - subroutine prn_set_stream(n) bind(C) - use ISO_C_BINDING - implicit none - integer(C_INT), value :: n - end subroutine prn_set_stream - end interface -end module random_lcg diff --git a/src/settings.F90 b/src/settings.F90 deleted file mode 100644 index f38cb6ae50..0000000000 --- a/src/settings.F90 +++ /dev/null @@ -1,40 +0,0 @@ -module settings - - use, intrinsic :: ISO_C_BINDING - - use constants - - implicit none - - ! ============================================================================ - ! CONTINUOUS-ENERGY CROSS SECTION RELATED VARIABLES - - logical(C_BOOL), bind(C) :: photon_transport - - ! ============================================================================ - ! SIMULATION VARIABLES - - ! Assume all tallies are spatially distinct - logical(C_BOOL), bind(C) :: assume_separate - - integer(C_INT64_T), bind(C) :: n_particles ! # of particles per generation - integer(C_INT32_T), bind(C) :: n_inactive ! # of inactive batches - - logical(C_BOOL), bind(C) :: trigger_on ! flag for turning triggers on/off - - ! Mode to run in (fixed source, eigenvalue, plotting, etc) - integer(C_INT), bind(C) :: run_mode - - ! flag for use of DAGMC geometry - logical(C_BOOL), bind(C) :: dagmc - - ! The verbosity controls how much information will be printed to the screen - ! and in logs - integer(C_INT), bind(C) :: verbosity - - character(MAX_FILE_LEN) :: path_input ! Path to input file - - ! No reduction at end of batch - logical(C_BOOL), bind(C) :: reduce_tallies - -end module settings diff --git a/src/simulation_header.F90 b/src/simulation_header.F90 deleted file mode 100644 index 675306346c..0000000000 --- a/src/simulation_header.F90 +++ /dev/null @@ -1,88 +0,0 @@ -module simulation_header - - use, intrinsic :: ISO_C_BINDING - - use bank_header - use constants - use stl_vector, only: VectorReal - - implicit none - - ! ============================================================================ - ! GEOMETRY-RELATED VARIABLES - - ! Number of lost particles - integer(C_INT), bind(C) :: n_lost_particles - - ! ============================================================================ - ! SIMULATION VARIABLES - - integer(C_INT), bind(C) :: current_batch ! current batch - integer(C_INT), bind(C) :: current_gen ! current generation within a batch - integer(C_INT), bind(C) :: total_gen ! total number of generations simulated - logical(C_BOOL), bind(C) :: need_depletion_rx ! need to calculate depletion reaction rx? - - integer(C_INT64_T), bind(C) :: work ! number of particles per processor - - ! ============================================================================ - ! K-EIGENVALUE SIMULATION VARIABLES - - ! Temporary k-effective values - real(C_DOUBLE), bind(C) :: keff ! average k over active batches - real(C_DOUBLE), bind(C) :: keff_std ! standard deviation of average k - - ! ============================================================================ - ! PARALLEL PROCESSING VARIABLES - -#ifdef _OPENMP - integer(C_INT), bind(C) :: n_threads ! number of OpenMP threads -#endif - - ! ============================================================================ - ! MISCELLANEOUS VARIABLES - - integer(C_INT), bind(C) :: restart_batch - - interface - subroutine entropy_clear() bind(C) - end subroutine - - pure function overall_generation() result(gen) bind(C) - import C_INT - integer(C_INT) :: gen - end function overall_generation - - function k_generation(i) result(k) bind(C) - import C_DOUBLE, C_INT - integer(C_INT), value :: i - real(C_DOUBLE) :: k - end function - - function k_generation_size() result(sz) bind(C) - import C_INT - integer(C_INT) :: sz - end function - - subroutine k_generation_clear() bind(C) - end subroutine - - function work_index(rank) result(i) bind(C) - import C_INT, C_INT64_T - integer(C_INT), value :: rank - integer(C_INT64_T) :: i - end function - end interface - -contains - -!=============================================================================== -! FREE_MEMORY_SIMULATION deallocates global arrays defined in this module -!=============================================================================== - - subroutine free_memory_simulation() - - call k_generation_clear() - call entropy_clear() - end subroutine free_memory_simulation - -end module simulation_header diff --git a/src/stl_vector.F90 b/src/stl_vector.F90 deleted file mode 100644 index 1562907814..0000000000 --- a/src/stl_vector.F90 +++ /dev/null @@ -1,550 +0,0 @@ -module stl_vector - - ! This module provides derived types that are meant to mimic the - ! std::vector type in C++. The vector type has numerous advantages over - ! simple arrays and linked lists in that storage can grow and shrink - ! dynamically, yet it is still contiguous in memory. Vectors can be filled - ! element-by-element with automatic memory allocation in amortized constant - ! time. In the implementation here, we grow the vector by a factor of 1.5 each - ! time the capacity is exceed. - ! - ! The member functions which have been implemented here are: - ! - ! capacity -- Returns the size of the storage space currently allocated for - ! the vector - ! - ! clear -- Remove all elements from the vector, leaving it with a size of - ! 0. Note that this doesn't imply that storage is deallocated. - ! - ! initialize -- Set the storage size of the vector and optionally fill it with - ! a particular value. - ! - ! pop_back -- Remove the last element of the vector, reducing the size by one. - ! - ! push_back -- Add a new element at the end of the vector. This increases the - ! size of the vector by one. Note that the underlying storage is - ! reallocated only if the size exceeds the capacity. - ! - ! reserve -- Requests that the capacity of the vector be a certain size. - ! - ! resize -- Resize the vector so it contains n elements. If n is larger than - ! the current size, an optional fill value can be used to set the - ! extra elements. - ! - ! shrink_to_fit -- Request that the capacity be reduced to fit the size. - ! - ! size -- Returns the number of elements in the vector. - - use, intrinsic :: ISO_C_BINDING - - implicit none - private - - integer, parameter :: VECTOR_CHAR_LEN = 255 - real(8), parameter :: GROWTH_FACTOR = 1.5 - - type, public :: VectorInt - integer, private :: size_ = 0 - integer, private :: capacity_ = 0 - integer, allocatable :: data(:) - contains - procedure :: capacity => capacity_int - procedure :: clear => clear_int - generic :: initialize => & - initialize_fill_int - procedure, private :: initialize_fill_int - procedure :: pop_back => pop_back_int - procedure :: push_back => push_back_int - procedure :: reserve => reserve_int - procedure :: resize => resize_int - procedure :: shrink_to_fit => shrink_to_fit_int - procedure :: size => size_int - end type VectorInt - - type, public :: VectorReal - integer, private :: size_ = 0 - integer, private :: capacity_ = 0 - real(8), allocatable :: data(:) - contains - procedure :: capacity => capacity_real - procedure :: clear => clear_real - generic :: initialize => & - initialize_fill_real - procedure, private :: initialize_fill_real - procedure :: pop_back => pop_back_real - procedure :: push_back => push_back_real - procedure :: reserve => reserve_real - procedure :: resize => resize_real - procedure :: shrink_to_fit => shrink_to_fit_real - procedure :: size => size_real - end type VectorReal - - type, public :: VectorChar - integer, private :: size_ = 0 - integer, private :: capacity_ = 0 - character(VECTOR_CHAR_LEN), allocatable :: data(:) - contains - procedure :: capacity => capacity_char - procedure :: clear => clear_char - generic :: initialize => & - initialize_fill_char - procedure, private :: initialize_fill_char - procedure :: pop_back => pop_back_char - procedure :: push_back => push_back_char - procedure :: reserve => reserve_char - procedure :: resize => resize_char - procedure :: shrink_to_fit => shrink_to_fit_char - procedure :: size => size_char - end type VectorChar - -contains - -!=============================================================================== -! Implementation of VectorInt -!=============================================================================== - - pure function capacity_int(this) result(capacity) - class(VectorInt), intent(in) :: this - integer :: capacity - - capacity = this%capacity_ - end function capacity_int - - subroutine clear_int(this) - class(VectorInt), intent(inout) :: this - - ! Since integer is trivially destructible, we only need to set size to zero - ! and can leave capacity as is - this%size_ = 0 - if (allocated(this % data)) then - this%capacity_ = size(this % data) - else - this%capacity_ = 0 - end if - end subroutine clear_int - - subroutine initialize_fill_int(this, n, val) - class(VectorInt), intent(inout) :: this - integer, intent(in) :: n - integer, optional, intent(in) :: val - - integer :: val_ - - ! If no value given, fill the vector with zeros - if (present(val)) then - val_ = val - else - val_ = 0 - end if - - if (allocated(this%data)) deallocate(this%data) - - allocate(this%data(n), SOURCE=val_) - this%size_ = n - this%capacity_ = n - end subroutine initialize_fill_int - - subroutine pop_back_int(this) - class(VectorInt), intent(inout) :: this - if (this%size_ > 0) this%size_ = this%size_ - 1 - end subroutine pop_back_int - - subroutine push_back_int(this, val) - class(VectorInt), intent(inout) :: this - integer, intent(in) :: val - - integer :: capacity - integer, allocatable :: data(:) - - if (this%capacity_ == this%size_) then - ! Create new data array that is GROWTH_FACTOR larger. Note that - if (this%capacity_ == 0) then - capacity = 8 - else - capacity = int(GROWTH_FACTOR*this%capacity_) - end if - allocate(data(capacity)) - - ! Copy existing elements - if (this%size_ > 0) data(1:this%size_) = this%data - - ! Move allocation - call move_alloc(FROM=data, TO=this%data) - this%capacity_ = capacity - end if - - ! Increase size of vector by one and set new element - this%size_ = this%size_ + 1 - this%data(this%size_) = val - end subroutine push_back_int - - subroutine reserve_int(this, n) - class(VectorInt), intent(inout) :: this - integer, intent(in) :: n - - integer, allocatable :: data(:) - - if (n > this%capacity_) then - allocate(data(n)) - - ! Copy existing elements - if (this%size_ > 0) data(1:this%size_) = this%data(1:this%size_) - - ! Move allocation - call move_alloc(FROM=data, TO=this%data) - this%capacity_ = n - end if - end subroutine reserve_int - - subroutine resize_int(this, n, val) - class(VectorInt), intent(inout) :: this - integer, intent(in) :: n - integer, intent(in), optional :: val - - if (n < this%size_) then - this%size_ = n - elseif (n > this%size_) then - ! If requested size is greater than capacity, first reserve that many - ! elements - if (n > this%capacity_) call this%reserve(n) - - ! Fill added elements with specified value and increase size - if (present(val)) this%data(this%size_ + 1 : n) = val - this%size_ = n - end if - - end subroutine resize_int - - subroutine shrink_to_fit_int(this) - class(VectorInt), intent(inout) :: this - - integer, allocatable :: data(:) - - if (this%capacity_ > this%size_) then - if (this%size_ > 0) then - allocate(data(this%size_)) - data(:) = this%data(1:this%size_) - call move_alloc(FROM=data, TO=this%data) - this%capacity_ = this%size_ - else - if (allocated(this%data)) deallocate(this%data) - end if - end if - end subroutine shrink_to_fit_int - - pure function size_int(this) result(size) - class(VectorInt), intent(in) :: this - integer :: size - - size = this%size_ - end function size_int - -!=============================================================================== -! Implementation of VectorReal -!=============================================================================== - - pure function capacity_real(this) result(capacity) - class(VectorReal), intent(in) :: this - integer :: capacity - - capacity = this%capacity_ - end function capacity_real - - subroutine clear_real(this) - class(VectorReal), intent(inout) :: this - - ! Since real is trivially destructible, we only need to set size to zero and - ! can leave capacity as is - this%size_ = 0 - if (allocated(this % data)) then - this%capacity_ = size(this % data) - else - this%capacity_ = 0 - end if - end subroutine clear_real - - subroutine initialize_fill_real(this, n, val) - class(VectorReal), intent(inout) :: this - integer, intent(in) :: n - real(8), optional, intent(in) :: val - - real(8) :: val_ - - ! If no value given, fill the vector with zeros - if (present(val)) then - val_ = val - else - val_ = 0 - end if - - if (allocated(this%data)) deallocate(this%data) - - allocate(this%data(n), SOURCE=val_) - this%size_ = n - this%capacity_ = n - end subroutine initialize_fill_real - - subroutine pop_back_real(this) - class(VectorReal), intent(inout) :: this - if (this%size_ > 0) this%size_ = this%size_ - 1 - end subroutine pop_back_real - - subroutine push_back_real(this, val) - class(VectorReal), intent(inout) :: this - real(8), intent(in) :: val - - integer :: capacity - real(8), allocatable :: data(:) - - if (this%capacity_ == this%size_) then - ! Create new data array that is GROWTH_FACTOR larger. Note that - if (this%capacity_ == 0) then - capacity = 8 - else - capacity = int(GROWTH_FACTOR*this%capacity_) - end if - allocate(data(capacity)) - - ! Copy existing elements - if (this%size_ > 0) data(1:this%size_) = this%data - - ! Move allocation - call move_alloc(FROM=data, TO=this%data) - this%capacity_ = capacity - end if - - ! Increase size of vector by one and set new element - this%size_ = this%size_ + 1 - this%data(this%size_) = val - end subroutine push_back_real - - subroutine reserve_real(this, n) - class(VectorReal), intent(inout) :: this - integer, intent(in) :: n - - real(8), allocatable :: data(:) - - if (n > this%capacity_) then - allocate(data(n)) - - ! Copy existing elements - if (this%size_ > 0) data(1:this%size_) = this%data(1:this%size_) - - ! Move allocation - call move_alloc(FROM=data, TO=this%data) - this%capacity_ = n - end if - end subroutine reserve_real - - subroutine resize_real(this, n, val) - class(VectorReal), intent(inout) :: this - integer, intent(in) :: n - real(8), intent(in), optional :: val - - if (n < this%size_) then - this%size_ = n - elseif (n > this%size_) then - ! If requested size is greater than capacity, first reserve that many - ! elements - if (n > this%capacity_) call this%reserve(n) - - ! Fill added elements with specified value and increase size - if (present(val)) this%data(this%size_ + 1 : n) = val - this%size_ = n - end if - - end subroutine resize_real - - subroutine shrink_to_fit_real(this) - class(VectorReal), intent(inout) :: this - - real(8), allocatable :: data(:) - - if (this%capacity_ > this%size_) then - if (this%size_ > 0) then - allocate(data(this%size_)) - data(:) = this%data(1:this%size_) - call move_alloc(FROM=data, TO=this%data) - this%capacity_ = this%size_ - else - if (allocated(this%data)) deallocate(this%data) - end if - end if - end subroutine shrink_to_fit_real - - pure function size_real(this) result(size) - class(VectorReal), intent(in) :: this - integer :: size - - size = this%size_ - end function size_real - -!=============================================================================== -! Implementation of VectorChar -!=============================================================================== - - pure function capacity_char(this) result(capacity) - class(VectorChar), intent(in) :: this - integer :: capacity - - capacity = this%capacity_ - end function capacity_char - - subroutine clear_char(this) - class(VectorChar), intent(inout) :: this - - ! Since char is trivially destructible, we only need to set size to zero and - ! can leave capacity as is - this%size_ = 0 - if (allocated(this % data)) then - this%capacity_ = size(this % data) - else - this%capacity_ = 0 - end if - end subroutine clear_char - - subroutine initialize_fill_char(this, n, val) - class(VectorChar), intent(inout) :: this - integer, intent(in) :: n - character(*), optional, intent(in) :: val - - integer :: i - character(VECTOR_CHAR_LEN) :: val_ - - ! If no value given, fill the vector with empty strings - if (present(val)) then - val_ = val - else - val_ = '' - end if - - if (allocated(this%data)) deallocate(this%data) - - allocate(this%data(n)) - do i = 1, n - this%data(i) = val_ - end do - this%size_ = n - this%capacity_ = n - end subroutine initialize_fill_char - - subroutine pop_back_char(this) - class(VectorChar), intent(inout) :: this - if (this%size_ > 0) this%size_ = this%size_ - 1 - end subroutine pop_back_char - - subroutine push_back_char(this, val) - class(VectorChar), intent(inout) :: this - character(*), intent(in) :: val - - integer :: capacity - character(VECTOR_CHAR_LEN), allocatable :: data(:) - - if (this%capacity_ == this%size_) then - ! Create new data array that is GROWTH_FACTOR larger. Note that - if (this%capacity_ == 0) then - capacity = 8 - else - capacity = int(GROWTH_FACTOR*this%capacity_) - end if - allocate(data(capacity)) - - ! Copy existing elements - if (this%size_ > 0) data(1:this%size_) = this%data - - ! Move allocation - call move_alloc(FROM=data, TO=this%data) - this%capacity_ = capacity - end if - - ! Increase size of vector by one and set new element - this%size_ = this%size_ + 1 - this%data(this%size_) = val - end subroutine push_back_char - - subroutine reserve_char(this, n) - class(VectorChar), intent(inout) :: this - integer, intent(in) :: n - - character(VECTOR_CHAR_LEN), allocatable :: data(:) - - if (n > this%capacity_) then - allocate(data(n)) - - ! Copy existing elements - if (this%size_ > 0) data(1:this%size_) = this%data(1:this%size_) - - ! Move allocation - call move_alloc(FROM=data, TO=this%data) - this%capacity_ = n - end if - end subroutine reserve_char - - subroutine resize_char(this, n, val) - class(VectorChar), intent(inout) :: this - integer, intent(in) :: n - character(*), intent(in), optional :: val - - if (n < this%size_) then - this%size_ = n - elseif (n > this%size_) then - ! If requested size is greater than capacity, first reserve that many - ! elements - if (n > this%capacity_) call this%reserve(n) - - ! Fill added elements with specified value and increase size - if (present(val)) this%data(this%size_ + 1 : n) = val - this%size_ = n - end if - - end subroutine resize_char - - subroutine shrink_to_fit_char(this) - class(VectorChar), intent(inout) :: this - - character(VECTOR_CHAR_LEN), allocatable :: data(:) - - if (this%capacity_ > this%size_) then - if (this%size_ > 0) then - allocate(data(this%size_)) - data(:) = this%data(1:this%size_) - call move_alloc(FROM=data, TO=this%data) - this%capacity_ = this%size_ - else - if (allocated(this%data)) deallocate(this%data) - end if - end if - end subroutine shrink_to_fit_char - - pure function size_char(this) result(size) - class(VectorChar), intent(in) :: this - integer :: size - - size = this%size_ - end function size_char - -!=============================================================================== -! Procedures to be called from C++ -!=============================================================================== - - subroutine vector_int_push_back(ptr, val) bind(C) - type(C_PTR), value :: ptr - integer(C_INT), value :: val - - type(VectorInt), pointer :: vec - - call C_F_POINTER(ptr, vec) - call vec % push_back(val) - end subroutine - - subroutine vector_real_push_back(ptr, val) bind(C) - type(C_PTR), value :: ptr - real(C_DOUBLE), value :: val - - type(VectorReal), pointer :: vec - - call C_F_POINTER(ptr, vec) - call vec % push_back(val) - end subroutine - -end module stl_vector diff --git a/src/string.F90 b/src/string.F90 deleted file mode 100644 index 20fd36c469..0000000000 --- a/src/string.F90 +++ /dev/null @@ -1,355 +0,0 @@ -module string - - use, intrinsic :: ISO_C_BINDING - - use constants, only: ERROR_INT, ERROR_REAL - use error, only: fatal_error - - implicit none - - interface to_str - module procedure int4_to_str, int8_to_str, real_to_str - end interface - -contains - -!=============================================================================== -! TO_LOWER converts a string to all lower case characters -!=============================================================================== - - pure function to_lower(word) result(word_lower) - character(*), intent(in) :: word - character(len=len(word)) :: word_lower - - integer :: i - integer :: ic - - do i = 1, len(word) - ic = ichar(word(i:i)) - if (ic >= 65 .and. ic <= 90) then - word_lower(i:i) = char(ic+32) - else - word_lower(i:i) = word(i:i) - end if - end do - - end function to_lower - -!=============================================================================== -! TO_UPPER converts a string to all upper case characters -!=============================================================================== - - pure function to_upper(word) result(word_upper) - character(*), intent(in) :: word - character(len=len(word)) :: word_upper - - integer :: i - integer :: ic - - do i = 1, len(word) - ic = ichar(word(i:i)) - if (ic >= 97 .and. ic <= 122) then - word_upper(i:i) = char(ic-32) - else - word_upper(i:i) = word(i:i) - end if - end do - - end function to_upper - -!=============================================================================== -! ZERO_PADDED returns a string of the input integer padded with zeros to the -! desired number of digits. Do not include the sign in n_digits for negative -! integers. -!=============================================================================== - - function zero_padded(num, n_digits) result(str) - integer, intent(in) :: num - integer, intent(in) :: n_digits - character(11) :: str - - character(8) :: zp_form - - ! Make sure n_digits is reasonable. 10 digits is the maximum needed for the - ! largest integer(4). - if (n_digits > 10) then - call fatal_error('zero_padded called with an unreasonably large & - &n_digits (>10)') - end if - - ! Write a format string of the form '(In.m)' where n is the max width and - ! m is the min width. If a sign is present, then n must be one greater - ! than m. - if (num < 0) then - write(zp_form, '("(I", I0, ".", I0, ")")') n_digits+1, n_digits - else - write(zp_form, '("(I", I0, ".", I0, ")")') n_digits, n_digits - end if - - ! Format the number. - write(str, zp_form) num - end function zero_padded - -!=============================================================================== -! IS_NUMBER determines whether a string of characters is all 0-9 characters -!=============================================================================== - - pure function is_number(word) result(number) - character(*), intent(in) :: word - logical :: number - - integer :: i - integer :: ic - - number = .true. - do i = 1, len_trim(word) - ic = ichar(word(i:i)) - if (ic < 48 .or. ic >= 58) number = .false. - end do - - end function is_number - -!=============================================================================== -! STARTS_WITH determines whether a string starts with a certain -! sequence of characters -!=============================================================================== - - pure logical function starts_with(str, seq) - character(*), intent(in) :: str ! string to check - character(*), intent(in) :: seq ! sequence of characters - - integer :: i - integer :: i_start - integer :: str_len - integer :: seq_len - - str_len = len_trim(str) - seq_len = len_trim(seq) - - ! determine how many spaces are at beginning of string - i_start = 0 - do i = 1, str_len - if (str(i:i) == ' ' .or. str(i:i) == achar(9)) cycle - i_start = i - exit - end do - - ! Check if string starts with sequence using INDEX intrinsic - if (index(str(1:str_len), seq(1:seq_len)) == i_start) then - starts_with = .true. - else - starts_with = .false. - end if - - end function starts_with - -!=============================================================================== -! ENDS_WITH determines whether a string ends with a certain sequence -! of characters -!=============================================================================== - - pure logical function ends_with(str, seq) - character(*), intent(in) :: str ! string to check - character(*), intent(in) :: seq ! sequence of characters - - integer :: i_start - integer :: str_len - integer :: seq_len - - str_len = len_trim(str) - seq_len = len_trim(seq) - - ! determine how many spaces are at beginning of string - i_start = str_len - seq_len + 1 - - ! Check if string starts with sequence using INDEX intrinsic - if (index(str(1:str_len), seq(1:seq_len), .true.) == i_start) then - ends_with = .true. - else - ends_with = .false. - end if - - end function ends_with - -!=============================================================================== -! INT4_TO_STR converts an integer(4) to a string. -!=============================================================================== - - pure function int4_to_str(num) result(str) - - integer, intent(in) :: num - character(11) :: str - - write (str, '(I11)') num - str = adjustl(str) - - end function int4_to_str - -!=============================================================================== -! INT8_TO_STR converts an integer(8) to a string. -!=============================================================================== - - pure function int8_to_str(num) result(str) - - integer(8), intent(in) :: num - character(21) :: str - - write (str, '(I21)') num - str = adjustl(str) - - end function int8_to_str - -!=============================================================================== -! STR_TO_INT converts a string to an integer. -!=============================================================================== - - pure function str_to_int(str) result(num) - - character(*), intent(in) :: str - integer(8) :: num - - character(5) :: fmt - integer :: w - integer :: ioError - - ! Determine width of string - w = len_trim(str) - - ! Create format specifier for reading string - write(UNIT=fmt, FMT='("(I",I2,")")') w - - ! read string into integer - read(UNIT=str, FMT=fmt, IOSTAT=ioError) num - if (ioError > 0) num = ERROR_INT - - end function str_to_int - -!=============================================================================== -! REAL_TO_STR converts a real(8) to a string based on how large the value is and -! how many significant digits are desired. By default, six significants digits -! are used. -!=============================================================================== - - pure function real_to_str(num, sig_digits) result(string) - - real(8), intent(in) :: num ! number to convert - integer, optional, intent(in) :: sig_digits ! # of significant digits - character(15) :: string ! string returned - - integer :: decimal ! number of places after decimal - integer :: width ! total field width - real(8) :: num2 ! absolute value of number - character(9) :: fmt ! format specifier for writing number - - ! set default field width - width = 15 - - ! set number of places after decimal - if (present(sig_digits)) then - decimal = sig_digits - else - decimal = 6 - end if - - ! Create format specifier for writing character - num2 = abs(num) - if (num2 == 0.0_8) then - write(fmt, '("(F",I2,".",I2,")")') width, 1 - elseif (num2 < 1.0e-1_8) then - write(fmt, '("(ES",I2,".",I2,")")') width, decimal - 1 - elseif (num2 >= 1.0e-1_8 .and. num2 < 1.0_8) then - write(fmt, '("(F",I2,".",I2,")")') width, decimal - elseif (num2 >= 1.0_8 .and. num2 < 10.0_8) then - write(fmt, '("(F",I2,".",I2,")")') width, max(decimal-1, 0) - elseif (num2 >= 10.0_8 .and. num2 < 100.0_8) then - write(fmt, '("(F",I2,".",I2,")")') width, max(decimal-2, 0) - elseif (num2 >= 100.0_8 .and. num2 < 1000.0_8) then - write(fmt, '("(F",I2,".",I2,")")') width, max(decimal-3, 0) - elseif (num2 >= 100.0_8 .and. num2 < 10000.0_8) then - write(fmt, '("(F",I2,".",I2,")")') width, max(decimal-4, 0) - elseif (num2 >= 10000.0_8 .and. num2 < 100000.0_8) then - write(fmt, '("(F",I2,".",I2,")")') width, max(decimal-5, 0) - else - write(fmt, '("(ES",I2,".",I2,")")') width, decimal - 1 - end if - - ! Write string and left adjust - write(string, fmt) num - string = adjustl(string) - - end function real_to_str - -!=============================================================================== -! WORD_COUNT determines the number of words in a string -!=============================================================================== - - function word_count(str) result(n) - character(*), intent(in) :: str - integer :: n - - integer :: i - character(kind=C_CHAR) :: chr - logical :: inword - - ! Count number of words - inword = .false. - n = 0 - do i = 1, len_trim(str) - chr = str(i:i) - select case (chr) - case (' ', C_HORIZONTAL_TAB, C_NEW_LINE, C_CARRIAGE_RETURN) - if (inword) then - inword = .false. - n = n + 1 - end if - case default - inword = .true. - end select - end do - if (inword) n = n + 1 - end function word_count - -!=============================================================================== -! TO_F_STRING takes a null-terminated array of C chars and turns it into a -! deferred-length character string. Yay Fortran 2003! -!=============================================================================== - - function to_f_string(c_string) result(f_string) - character(kind=C_CHAR), intent(in) :: c_string(*) - character(:), allocatable :: f_string - - integer :: i, n - - ! Determine length of original string - n = 0 - do while (c_string(n + 1) /= C_NULL_CHAR) - n = n + 1 - end do - - ! Copy C string character by character - allocate(character(len=n) :: f_string) - do i = 1, n - f_string(i:i) = c_string(i) - end do - end function to_f_string - -!=============================================================================== -! TO_C_STRING takes a space-padded Fortran character and turns it into a -! null-terminated C char array. Yay Fortran 2003! -!=============================================================================== - - function to_c_string(f_string) result(c_string) - character(*), intent(in) :: f_string - character(kind=C_CHAR) :: c_string(len_trim(f_string) + 1) - - integer :: i, n - - ! Copy Fortran string character by character - n = len_trim(f_string) - do i = 1, n - c_string(i) = f_string(i:i) - end do - c_string(n + 1) = C_NULL_CHAR - end function to_c_string - -end module string diff --git a/src/vector_header.F90 b/src/vector_header.F90 deleted file mode 100644 index fd7726c79e..0000000000 --- a/src/vector_header.F90 +++ /dev/null @@ -1,113 +0,0 @@ -module vector_header - - use constants, only: ZERO - - implicit none - private - - type, public :: Vector - integer :: n ! number of rows/cols in matrix - real(8), allocatable :: data(:) ! where vector data is stored - real(8), pointer :: val(:) ! pointer to vector data - contains - procedure :: create => vector_create - procedure :: destroy => vector_destroy - procedure :: add_value => vector_add_value - procedure :: copy => vector_copy - procedure :: write => vector_write - end type Vector - -contains - -!=============================================================================== -! VECTOR_CREATE allocates and initializes a vector -!=============================================================================== - - subroutine vector_create(self, n) - - integer, intent(in) :: n ! size of vector - class(Vector), intent(inout), target :: self ! vector instance - - ! Preallocate vector - if (.not.allocated(self % data)) allocate(self % data(n)) - self % val => self % data(1:n) - - ! Set n - self % n = n - - ! Initialize to zero - self % val = ZERO - - end subroutine vector_create - -!=============================================================================== -! VECTOR_DESTROY deallocates all space associated with a vector -!=============================================================================== - - subroutine vector_destroy(self) - - class(Vector), intent(inout) :: self ! vector instance - - if (associated(self % val)) nullify(self % val) - if (allocated(self % data)) deallocate(self % data) - - end subroutine vector_destroy - -!=============================================================================== -! VECTOR_ADD_VALUE adds a value to the vector -!=============================================================================== - - subroutine vector_add_value(self, idx, val) - - integer, intent(in) :: idx ! index location in vector - real(8), intent(in) :: val ! value to add - class(Vector), intent(inout) :: self ! vector instance - - self % val(idx) = val - - end subroutine vector_add_value - -!=============================================================================== -! VECTOR_COPY allocates a separate vector and copies -!=============================================================================== - - subroutine vector_copy(self, vectocopy) - - class(Vector), target, intent(inout) :: self - type(Vector), intent(in) :: vectocopy - - ! Preallocate vector - if (.not.allocated(self % data)) allocate(self % data(vectocopy % n)) - self % val => self % data(1:vectocopy % n) - - ! Set n - self % n = vectocopy % n - - ! Copy values - self % val = vectocopy % val - - end subroutine vector_copy - -!=============================================================================== -! VECTOR_WRITE writes a vector to file -!=============================================================================== - - subroutine vector_write(self, filename) - - class(Vector), target, intent(inout) :: self ! vector instance - character(*), intent(in) :: filename ! filename to output to - - integer :: unit_ - integer :: i - - open(newunit=unit_, file=filename) - - do i = 1, self % n - write(unit_,*) i, self % data(i) - end do - - close(unit_) - - end subroutine vector_write - -end module vector_header diff --git a/src/xml_interface.F90 b/src/xml_interface.F90 deleted file mode 100644 index 39c6330ec6..0000000000 --- a/src/xml_interface.F90 +++ /dev/null @@ -1,367 +0,0 @@ -module xml_interface - - use, intrinsic :: ISO_C_BINDING - - use error, only: fatal_error - use pugixml - use string, only: word_count - - implicit none - private - public :: XMLDocument, XMLNode, XMLText, XMLAttribute - public :: check_for_node - public :: get_node_list - public :: get_node_value - public :: get_node_value_bool - public :: get_node_array - public :: node_value_string - public :: node_word_count - - interface get_node_value - module procedure get_node_value_bool - module procedure get_node_value_cbool - module procedure get_node_value_integer - module procedure get_node_value_long - module procedure get_node_value_double - module procedure get_node_value_string - end interface get_node_value - - interface get_node_array - module procedure get_node_array_integer - module procedure get_node_array_double - module procedure get_node_array_string - end interface get_node_array - -contains - -!=============================================================================== -! CHECK_FOR_NODE checks for an attribute or sub-element node with the given -! node name. This should only be used for checking a single occurance of a -! sub-element node. -!=============================================================================== - - function check_for_node(node, name) result(found) - type(XMLNode), intent(in) :: node - character(len=*), intent(in) :: name - logical :: found - - type(XMLAttribute) :: attr - type(XMLNode) :: child - - ! Check if an attribute or exists - attr = node % attribute(name) - if (attr % associated()) then - found = .true. - else - child = node % child(name) - if (child % associated()) then - found = .true. - else - found = .false. - end if - end if - end function check_for_node - -!=============================================================================== -! GET_NODE_LIST is used to get a pointer to a list of sub-element nodes -!=============================================================================== - - subroutine get_node_list(node, name, node_list) - type(XMLNode), intent(in) :: node - character(*), intent(in) :: name - type(XMLNode), allocatable, intent(out) :: node_list(:) - - integer :: i, n - type(XMLNode) :: first, current - - first = node % child(name) - - ! Determine number of nodes - n = 0 - current = first - do while (current % associated()) - n = n + 1 - current = current % next_sibling(name) - end do - - ! Allocate nodes - allocate(node_list(n)) - current = first - do i = 1, n - node_list(i) = current - current = current % next_sibling(name) - end do - end subroutine get_node_list - -!=============================================================================== -! GET_NODE_VALUE_BOOL returns a logical value from an attribute or node -!=============================================================================== - - subroutine get_node_value_bool(node, name, val) - type(XMLNode), intent(in) :: node - character(*), intent(in) :: name - logical, intent(out) :: val - - type(XMLAttribute) :: attr - type(XMLNode) :: child - type(XMLText) :: text - - attr = node % attribute(name) - if (attr % associated()) then - val = attr % as_bool() - else - child = node % child(name) - if (child % associated()) then - text = child % text() - val = text % as_bool() - else - call fatal_error("No child XML node named '" // trim(name) // "'.") - end if - end if - end subroutine get_node_value_bool - - subroutine get_node_value_cbool(node, name, val) - type(XMLNode), intent(in) :: node - character(*), intent(in) :: name - logical(kind=C_BOOL), intent(out) :: val - - logical :: val_ - call get_node_value_bool(node, name, val_) - val = val_ - end subroutine get_node_value_cbool - -!=============================================================================== -! GET_NODE_VALUE_INTEGER returns a integer value from an attribute or node -!=============================================================================== - - subroutine get_node_value_integer(node, name, val) - type(XMLNode), intent(in) :: node - character(*), intent(in) :: name - integer, intent(out) :: val - - type(XMLAttribute) :: attr - type(XMLNode) :: child - type(XMLText) :: text - - attr = node % attribute(name) - if (attr % associated()) then - val = attr % as_int() - else - child = node % child(name) - if (child % associated()) then - text = child % text() - val = text % as_int() - else - call fatal_error("No XML node named '" // trim(name) // "'.") - end if - end if - end subroutine get_node_value_integer - -!=============================================================================== -! GET_NODE_VALUE_LONG returns an 8-byte integer from attribute or node -!=============================================================================== - - subroutine get_node_value_long(node, name, val) - type(XMLNode), intent(in) :: node - character(*), intent(in) :: name - integer(C_LONG_LONG), intent(out) :: val - - type(XMLAttribute) :: attr - type(XMLNode) :: child - type(XMLText) :: text - - attr = node % attribute(name) - if (attr % associated()) then - val = attr % as_llong() - else - child = node % child(name) - if (child % associated()) then - text = child % text() - val = text % as_llong() - else - call fatal_error("No XML node named '" // trim(name) // "'.") - end if - end if - end subroutine get_node_value_long - -!=============================================================================== -! GET_NODE_VALUE_DOUBLE returns a double precision real from attr. or node -!=============================================================================== - - subroutine get_node_value_double(node, name, val) - type(XMLNode), intent(in) :: node - character(*), intent(in) :: name - real(C_DOUBLE), intent(out) :: val - - type(XMLAttribute) :: attr - type(XMLNode) :: child - type(XMLText) :: text - - attr = node % attribute(name) - if (attr % associated()) then - val = attr % as_double() - else - child = node % child(name) - if (child % associated()) then - text = child % text() - val = text % as_double() - else - call fatal_error("No XML node named '" // trim(name) // "'.") - end if - end if - end subroutine get_node_value_double - -!=============================================================================== -! NODE_VALUE_STRING returns a single string from attr. or node -!=============================================================================== - - function node_value_string(node, name) result(val) - type(XMLNode), intent(in) :: node - character(*), intent(in) :: name - character(len=:, kind=C_CHAR), allocatable :: val - - type(XMLAttribute) :: attr - type(XMLNode) :: child - - attr = node % attribute(name) - if (attr % associated()) then - val = adjustl(attr % value()) - else - child = node % child(name) - if (child % associated()) then - val = adjustl(child % child_value()) - else - call fatal_error("No child XML node named '" // trim(name) // "'.") - end if - end if - end function node_value_string - -!=============================================================================== -! GET_NODE_VALUE_STRING returns a single string from attr. or node -!=============================================================================== - - subroutine get_node_value_string(node, name, val) - type(XMLNode), intent(in) :: node - character(*), intent(in) :: name - character(*), intent(out) :: val - - val = node_value_string(node, name) - end subroutine get_node_value_string - -!=============================================================================== -! NODE_WORD_COUNT returns the number of words in a text node or attribute value -!=============================================================================== - - integer function node_word_count(node, name) - type(XMLNode), intent(in) :: node - character(*), intent(in) :: name - - node_word_count = word_count(node_value_string(node, name)) - end function node_word_count - -!=============================================================================== -! GET_NODE_ARRAY_INTEGER returns a 1-D array of integers -!=============================================================================== - - subroutine get_node_array_integer(node, name, array) - type(XMLNode), intent(in) :: node - character(*), intent(in) :: name - integer, intent(out) :: array(:) - - integer :: stat - character(len=:, kind=C_CHAR), allocatable :: str - - ! Get value of text node/attribute - str = node_value_string(node, name) - call whitespace_to_blanks(str) - - ! Read numbers into array - read(UNIT=str, FMT=*, IOSTAT=stat) array - if (stat > 0) then - call fatal_error("Error converting XML text: " // trim(str)) - end if - end subroutine get_node_array_integer - -!=============================================================================== -! GET_NODE_ARRAY_DOUBLE returns a 1-D array of double precision reals -!=============================================================================== - - subroutine get_node_array_double(node, name, array) - type(XMLNode), intent(in) :: node - character(*), intent(in) :: name - real(C_DOUBLE), intent(out) :: array(:) - - integer :: stat - character(len=:, kind=C_CHAR), allocatable :: str - - ! Get value of text node/attribute - str = node_value_string(node, name) - call whitespace_to_blanks(str) - - ! Read numbers into array - read(UNIT=str, FMT=*, IOSTAT=stat) array - if (stat > 0) then - call fatal_error("Error converting XML text: " // trim(str)) - end if - end subroutine get_node_array_double - -!=============================================================================== -! GET_NODE_ARRAY_STRING returns a 1-D array of strings -!=============================================================================== - - subroutine get_node_array_string(node, name, array) - type(XMLNode), intent(in) :: node - character(*), intent(in) :: name - character(len=*), intent(out) :: array(:) - - integer :: i, n - integer :: start - logical :: inword - character(kind=C_CHAR) :: chr - character(len=:, kind=C_CHAR), allocatable :: str - - ! Get value of text node/attribute - str = node_value_string(node, name) - - inword = .false. - n = 0 - do i = 1, len(str) - chr = str(i:i) - select case (chr) - case (' ', C_HORIZONTAL_TAB, C_NEW_LINE, C_CARRIAGE_RETURN) - if (inword) then - inword = .false. - n = n + 1 - array(n) = str(start:i-1) - end if - case default - if (.not. inword) then - start = i - inword = .true. - end if - end select - end do - if (inword) then - n = n + 1 - array(n) = str(start:len(str)) - end if - end subroutine get_node_array_string - -!=============================================================================== -! WHITESPACE_TO_BLANKS converts all whitespace to blanks -!=============================================================================== - - subroutine whitespace_to_blanks(str) - character(len=*, kind=C_CHAR), intent(inout) :: str - - integer :: i - - do i = 1, len(str) - select case (str(i:i)) - case (C_NEW_LINE, C_HORIZONTAL_TAB, C_CARRIAGE_RETURN) - str(i:i) = ' ' - end select - end do - end subroutine - -end module xml_interface