From 8c1e0bdc781596973b86a592fe76704eeb49c127 Mon Sep 17 00:00:00 2001
From: "jke@jke_thinkpad_t460" <johannes.joachim.keller@rwth-aachen.de>
Date: Wed, 25 Mar 2020 18:34:23 +0100
Subject: [PATCH] SHEMAT-Suite: Version 9.00
---
.gitignore | 6 +
.gitlab/issue_templates/Error.md | 23 +
CMakeLists.txt | 93 +
LICENSE.md | 21 +
cmake/AD.cmake | 148 ++
cmake/Dependencies.cmake | 76 +
cmake/Flags.cmake | 60 +
cmake/Options.cmake | 73 +
cmake/Packages.cmake | 41 +
cmake/Sources.cmake | 137 ++
doc/Doxyfile | 2327 +++++++++++++++++++++++++
doc/doc_image/cube.png | Bin 0 -> 4345 bytes
forward/alloc_arrays.f90 | 423 +++++
forward/alloc_data.f90 | 87 +
forward/arrays.f90 | 738 ++++++++
forward/bhpr.f90 | 149 ++
forward/check_change.f90 | 134 ++
forward/check_props.f90 | 76 +
forward/check_units.f90 | 161 ++
forward/conc/calc_conc.f90 | 107 ++
forward/conc/cfluxes.f90 | 338 ++++
forward/conc/neumann_conc.f90 | 215 +++
forward/conc/peclet_conc.f90 | 226 +++
forward/conc/set_cbc.f90 | 226 +++
forward/conc/set_ccoef.f90 | 275 +++
forward/conc/set_cq.f90 | 66 +
forward/converged.f90 | 157 ++
forward/courant.f90 | 200 +++
forward/ctrlut/decntrl3.f90 | 45 +
forward/ctrlut/decntrl4.f90 | 49 +
forward/ctrlut/encntrl3.f90 | 35 +
forward/ctrlut/encntrl4.f90 | 36 +
forward/ctrlut/ijk_m.f90 | 91 +
forward/ctrlut/m_ijk.f90 | 36 +
forward/dealloc_arrays.f90 | 245 +++
forward/deltat.f90 | 220 +++
forward/forward_init.f90 | 78 +
forward/forward_iter.f90 | 210 +++
forward/forward_picard.f90 | 410 +++++
forward/forward_preparation.f90 | 70 +
forward/forward_wrapper.f90 | 43 +
forward/forward_write.f90 | 38 +
forward/get_tpbcalbe.f90 | 73 +
forward/head/calc_head.f90 | 95 +
forward/head/hbuoy.f90 | 58 +
forward/head/head2pres.f90 | 51 +
forward/head/hfluxes.f90 | 328 ++++
forward/head/hstor.f90 | 44 +
forward/head/neumann_head.f90 | 214 +++
forward/head/omp_head2pres.f90 | 83 +
forward/head/set_hbc.f90 | 193 ++
forward/head/set_hcoef.f90 | 168 ++
forward/head/set_hq.f90 | 64 +
forward/input/calc_deltatime.f90 | 152 ++
forward/input/read_array.f90 | 87 +
forward/input/read_bc.f90 | 839 +++++++++
forward/input/read_check.f90 | 295 ++++
forward/input/read_control.f90 | 79 +
forward/input/read_data.f90 | 656 +++++++
forward/input/read_model.f90 | 2028 +++++++++++++++++++++
forward/input/read_property.f90 | 76 +
forward/input/read_split.f90 | 142 ++
forward/input/read_time.f90 | 612 +++++++
forward/mathfuncs/alfa.f90 | 48 +
forward/mathfuncs/amean.f90 | 34 +
forward/mathfuncs/interpolate_lin.f90 | 125 ++
forward/mathfuncs/interpolate_pol.f90 | 290 +++
forward/mathfuncs/mean3d.f90 | 51 +
forward/mod_conc.f90 | 56 +
forward/mod_data.f90 | 35 +
forward/mod_flow.f90 | 102 ++
forward/mod_genrl.f90 | 253 +++
forward/mod_genrlc.f90 | 38 +
forward/mod_linfos.f90 | 53 +
forward/mod_temp.f90 | 34 +
forward/mod_time.f90 | 172 ++
forward/model_init.f90 | 75 +
forward/nlrelaxad.f90 | 68 +
forward/no_ext_link.f90 | 208 +++
forward/old_restore.f90 | 73 +
forward/old_save.f90 | 99 ++
forward/omp_bindtools.f90 | 262 +++
forward/omp_file_handler.f90 | 94 +
forward/omp_libnuma.c | 50 +
forward/omp_summe.f90 | 139 ++
forward/output/write_data.f90 | 113 ++
forward/output/write_dense3d.f90 | 90 +
forward/output/write_logs.f90 | 98 ++
forward/output/write_monitor.f90 | 303 ++++
forward/output/write_outt.f90 | 102 ++
forward/output/write_status_log.f90 | 64 +
forward/output/write_tecdiff.f90 | 137 ++
forward/output/write_tecplot.f90 | 737 ++++++++
forward/output/write_tecplotc.f90 | 149 ++
forward/output/write_text.f90 | 180 ++
forward/output/write_vtk.f90 | 307 ++++
forward/pres/calc_pres.f90 | 86 +
forward/pres/neumann_pres.f90 | 203 +++
forward/pres/omp_pres2head.f90 | 60 +
forward/pres/pbuoy.f90 | 105 ++
forward/pres/pfluxes.f90 | 365 ++++
forward/pres/pres2head.f90 | 51 +
forward/pres/pstor.f90 | 44 +
forward/pres/set_pbc.f90 | 218 +++
forward/pres/set_pcoef.f90 | 166 ++
forward/pres/set_pq.f90 | 64 +
forward/save_data.f90 | 152 ++
forward/set_tsal.f90 | 82 +
forward/set_var_deltat.f90 | 83 +
forward/shemach/compress_file.f90 | 45 +
forward/shemach/sys_cputime.f90 | 39 +
forward/shemach/sys_mkdir.f90 | 40 +
forward/stab_param.f90 | 50 +
forward/static_relaxation.f90 | 70 +
forward/strngut/beginlast.f90 | 45 +
forward/strngut/cfirst.f90 | 42 +
forward/strngut/chln.f90 | 60 +
forward/strngut/clast.f90 | 41 +
forward/strngut/found.f90 | 74 +
forward/strngut/get_arg.f90 | 51 +
forward/strngut/lblank.f90 | 41 +
forward/strngut/locstr.f90 | 54 +
forward/strngut/sfirst.f90 | 41 +
forward/temp/calc_temp.f90 | 90 +
forward/temp/neumann_temp.f90 | 203 +++
forward/temp/peclet_temp.f90 | 217 +++
forward/temp/set_tbc.f90 | 286 +++
forward/temp/set_tcoef.f90 | 274 +++
forward/temp/set_tq.f90 | 76 +
forward/temp/tfluxes.f90 | 356 ++++
forward/test_opt.f90 | 100 ++
hdf5/close_hdf5.f90 | 56 +
hdf5/closeopen_hdf5.f90 | 53 +
hdf5/mod_hdf5_vars.f90 | 59 +
hdf5/mod_input_file_parser_hdf5.f90 | 388 +++++
hdf5/open_hdf5.f90 | 60 +
hdf5/read_hdf5.f90 | 117 ++
hdf5/read_hdf5_int.f90 | 127 ++
hdf5/test_hdf5.f90 | 32 +
hdf5/write_all_hdf5.f90 | 698 ++++++++
props/bas/check_domain.f90 | 188 ++
props/bas/compf.f90 | 192 ++
props/bas/compm.f90 | 50 +
props/bas/cpf.f90 | 198 +++
props/bas/disp.f90 | 50 +
props/bas/kx.f90 | 54 +
props/bas/ky.f90 | 54 +
props/bas/kz.f90 | 50 +
props/bas/lamf.f90 | 84 +
props/bas/lamm.f90 | 128 ++
props/bas/lx.f90 | 98 ++
props/bas/ly.f90 | 98 ++
props/bas/lz.f90 | 98 ++
props/bas/por.f90 | 49 +
props/bas/props_check.f90 | 63 +
props/bas/props_end.f90 | 37 +
props/bas/props_init.f90 | 41 +
props/bas/qc.f90 | 55 +
props/bas/qf.f90 | 50 +
props/bas/qt.f90 | 51 +
props/bas/rce.f90 | 84 +
props/bas/read_props.f90 | 37 +
props/bas/rhocf.f90 | 62 +
props/bas/rhocm.f90 | 62 +
props/bas/rhof.f90 | 169 ++
props/bas/visf.f90 | 167 ++
props/basc/check_domain.f90 | 188 ++
props/basc/compf.f90 | 195 +++
props/basc/compm.f90 | 50 +
props/basc/compw.f90 | 180 ++
props/basc/cpf.f90 | 176 ++
props/basc/cpw.f90 | 179 ++
props/basc/disp.f90 | 50 +
props/basc/kx.f90 | 54 +
props/basc/ky.f90 | 54 +
props/basc/kz.f90 | 50 +
props/basc/lamf.f90 | 123 ++
props/basc/lamm.f90 | 128 ++
props/basc/lamw.f90 | 77 +
props/basc/lx.f90 | 98 ++
props/basc/ly.f90 | 98 ++
props/basc/lz.f90 | 98 ++
props/basc/por.f90 | 49 +
props/basc/props_check.f90 | 63 +
props/basc/props_end.f90 | 37 +
props/basc/props_init.f90 | 41 +
props/basc/qc.f90 | 55 +
props/basc/qf.f90 | 50 +
props/basc/qt.f90 | 51 +
props/basc/rce.f90 | 84 +
props/basc/read_props.f90 | 37 +
props/basc/rhocf.f90 | 62 +
props/basc/rhocm.f90 | 62 +
props/basc/rhof.f90 | 127 ++
props/basc/rhow.f90 | 105 ++
props/basc/visf.f90 | 112 ++
props/basc/visw.f90 | 124 ++
props/const/check_domain.f90 | 188 ++
props/const/compf.f90 | 50 +
props/const/compm.f90 | 49 +
props/const/cpf.f90 | 50 +
props/const/disp.f90 | 50 +
props/const/kx.f90 | 54 +
props/const/ky.f90 | 54 +
props/const/kz.f90 | 50 +
props/const/lamf.f90 | 49 +
props/const/lx.f90 | 72 +
props/const/ly.f90 | 72 +
props/const/lz.f90 | 71 +
props/const/mod_const.f90 | 64 +
props/const/por.f90 | 49 +
props/const/props_check.f90 | 63 +
props/const/props_end.f90 | 37 +
props/const/props_init.f90 | 41 +
props/const/qc.f90 | 55 +
props/const/qf.f90 | 50 +
props/const/qt.f90 | 51 +
props/const/rce.f90 | 84 +
props/const/read_props.f90 | 116 ++
props/const/rhocf.f90 | 47 +
props/const/rhocm.f90 | 50 +
props/const/rhof.f90 | 51 +
props/const/visf.f90 | 50 +
props/ghe/check_domain.f90 | 188 ++
props/ghe/compf.f90 | 192 ++
props/ghe/compm.f90 | 50 +
props/ghe/cpf.f90 | 198 +++
props/ghe/disp.f90 | 50 +
props/ghe/ghe_array.f90 | 54 +
props/ghe/ghe_hpr.f90 | 161 ++
props/ghe/kx.f90 | 72 +
props/ghe/ky.f90 | 72 +
props/ghe/kz.f90 | 69 +
props/ghe/lamf.f90 | 84 +
props/ghe/lamm.f90 | 128 ++
props/ghe/lx.f90 | 66 +
props/ghe/ly.f90 | 65 +
props/ghe/lz.f90 | 64 +
props/ghe/por.f90 | 49 +
props/ghe/props_check.f90 | 63 +
props/ghe/props_end.f90 | 37 +
props/ghe/props_init.f90 | 41 +
props/ghe/qc.f90 | 55 +
props/ghe/qf.f90 | 50 +
props/ghe/qt.f90 | 72 +
props/ghe/rce.f90 | 84 +
props/ghe/read_props.f90 | 37 +
props/ghe/rhocf.f90 | 62 +
props/ghe/rhocm.f90 | 62 +
props/ghe/rhof.f90 | 169 ++
props/ghe/visf.f90 | 167 ++
props/ice/check_domain.f90 | 115 ++
props/ice/compf.f90 | 115 ++
props/ice/compm.f90 | 46 +
props/ice/compw.f90 | 69 +
props/ice/cpf.f90 | 113 ++
props/ice/cpi.f90 | 66 +
props/ice/disp.f90 | 40 +
props/ice/ftheta.f90 | 139 ++
props/ice/ice.f90 | 33 +
props/ice/ice.inc | 23 +
props/ice/ice_allocate.f90 | 57 +
props/ice/kx.f90 | 63 +
props/ice/ky.f90 | 63 +
props/ice/kz.f90 | 63 +
props/ice/lamf.f90 | 62 +
props/ice/lami.f90 | 61 +
props/ice/lamm.f90 | 54 +
props/ice/lx.f90 | 76 +
props/ice/ly.f90 | 75 +
props/ice/lz.f90 | 74 +
props/ice/por.f90 | 41 +
props/ice/props_check.f90 | 56 +
props/ice/props_init.f90 | 81 +
props/ice/qc.f90 | 39 +
props/ice/qf.f90 | 38 +
props/ice/qt.f90 | 43 +
props/ice/rce.f90 | 74 +
props/ice/read_props.f90 | 86 +
props/ice/rhocf.f90 | 53 +
props/ice/rhoci.f90 | 50 +
props/ice/rhocm.f90 | 49 +
props/ice/rhof.f90 | 104 ++
props/ice/rhoi.f90 | 50 +
props/ice/rhow.f90 | 134 ++
props/ice/visf.f90 | 102 ++
shem_fw.f90 | 137 ++
solve/CMakeLists.txt | 30 +
solve/OMP_TOOLS.f90 | 52 +
solve/OMP_TOOLS.inc | 26 +
solve/counter.f90 | 54 +
solve/ddl_du.f90 | 114 ++
solve/dense_solve.f90 | 106 ++
solve/direct_solve.f90 | 165 ++
solve/get_dnorm.f90 | 57 +
solve/get_norm.f90 | 59 +
solve/get_norm2.f90 | 60 +
solve/mod_OMP_TOOLS.f90 | 27 +
solve/mod_blocking_size.f90 | 43 +
solve/norm_linsys.f90 | 83 +
solve/norm_linsys2.f90 | 84 +
solve/norm_resid.f90 | 46 +
solve/omp_abbruch.f90 | 277 +++
solve/omp_bayes_solve.f90 | 190 ++
solve/omp_damax.f90 | 83 +
solve/omp_ddot.f90 | 259 +++
solve/omp_gen_solve.f90 | 207 +++
solve/omp_gen_solve_diag.f90 | 208 +++
solve/omp_gen_solve_ilu.f90 | 326 ++++
solve/omp_gen_solve_ssor.f90 | 225 +++
solve/omp_mvp.f90 | 345 ++++
solve/omp_mvp2.f90 | 418 +++++
solve/omp_preconditioners.f90 | 1100 ++++++++++++
solve/omp_sym_solve.f90 | 180 ++
solve/omp_sym_solve_diag.f90 | 181 ++
solve/omp_sym_solve_ilu.f90 | 302 ++++
solve/omp_sym_solve_ssor.f90 | 196 +++
solve/p_pos_anz.f90 | 101 ++
solve/par_tools.f90 | 81 +
solve/pre_bicgstab.f90 | 580 ++++++
solve/pre_bicgstab.inc | 86 +
solve/pre_cg.f90 | 540 ++++++
solve/pre_cg.inc | 66 +
solve/preconditioners.f90 | 76 +
solve/prepare_solve.f90 | 317 ++++
solve/qddot.f90 | 130 ++
solve/reduction.f90 | 87 +
solve/set_dval.f90 | 60 +
solve/set_ival.f90 | 60 +
solve/set_lval.f90 | 60 +
solve/solve.f90 | 181 ++
solve/solve_debug.f90 | 124 ++
solve/solve_type.f90 | 231 +++
solve/ssor_mvp_single.f90 | 154 ++
solve/test_matrix.f90 | 152 ++
solve/test_symmetry.f90 | 72 +
solve/test_zero.f90 | 81 +
user/none/calc_user.f90 | 57 +
user/none/user_check.f90 | 50 +
user/none/write_monitor_user.f90 | 81 +
user/none/write_user.f90 | 65 +
user/wells3d/calc_user.f90 | 187 ++
user/wells3d/mod_wells3d.f90 | 47 +
user/wells3d/user_check.f90 | 50 +
user/wells3d/write_monitor_user.f90 | 81 +
user/wells3d/write_user.f90 | 65 +
version.inc.in | 15 +
347 files changed, 45917 insertions(+)
create mode 100644 .gitignore
create mode 100644 .gitlab/issue_templates/Error.md
create mode 100644 CMakeLists.txt
create mode 100644 LICENSE.md
create mode 100644 cmake/AD.cmake
create mode 100644 cmake/Dependencies.cmake
create mode 100644 cmake/Flags.cmake
create mode 100644 cmake/Options.cmake
create mode 100644 cmake/Packages.cmake
create mode 100644 cmake/Sources.cmake
create mode 100644 doc/Doxyfile
create mode 100644 doc/doc_image/cube.png
create mode 100644 forward/alloc_arrays.f90
create mode 100644 forward/alloc_data.f90
create mode 100644 forward/arrays.f90
create mode 100644 forward/bhpr.f90
create mode 100644 forward/check_change.f90
create mode 100644 forward/check_props.f90
create mode 100644 forward/check_units.f90
create mode 100644 forward/conc/calc_conc.f90
create mode 100644 forward/conc/cfluxes.f90
create mode 100644 forward/conc/neumann_conc.f90
create mode 100644 forward/conc/peclet_conc.f90
create mode 100644 forward/conc/set_cbc.f90
create mode 100644 forward/conc/set_ccoef.f90
create mode 100644 forward/conc/set_cq.f90
create mode 100644 forward/converged.f90
create mode 100644 forward/courant.f90
create mode 100644 forward/ctrlut/decntrl3.f90
create mode 100644 forward/ctrlut/decntrl4.f90
create mode 100644 forward/ctrlut/encntrl3.f90
create mode 100644 forward/ctrlut/encntrl4.f90
create mode 100644 forward/ctrlut/ijk_m.f90
create mode 100644 forward/ctrlut/m_ijk.f90
create mode 100644 forward/dealloc_arrays.f90
create mode 100644 forward/deltat.f90
create mode 100644 forward/forward_init.f90
create mode 100644 forward/forward_iter.f90
create mode 100644 forward/forward_picard.f90
create mode 100644 forward/forward_preparation.f90
create mode 100644 forward/forward_wrapper.f90
create mode 100644 forward/forward_write.f90
create mode 100644 forward/get_tpbcalbe.f90
create mode 100644 forward/head/calc_head.f90
create mode 100644 forward/head/hbuoy.f90
create mode 100644 forward/head/head2pres.f90
create mode 100644 forward/head/hfluxes.f90
create mode 100644 forward/head/hstor.f90
create mode 100644 forward/head/neumann_head.f90
create mode 100644 forward/head/omp_head2pres.f90
create mode 100644 forward/head/set_hbc.f90
create mode 100644 forward/head/set_hcoef.f90
create mode 100644 forward/head/set_hq.f90
create mode 100644 forward/input/calc_deltatime.f90
create mode 100644 forward/input/read_array.f90
create mode 100644 forward/input/read_bc.f90
create mode 100644 forward/input/read_check.f90
create mode 100644 forward/input/read_control.f90
create mode 100644 forward/input/read_data.f90
create mode 100644 forward/input/read_model.f90
create mode 100644 forward/input/read_property.f90
create mode 100644 forward/input/read_split.f90
create mode 100644 forward/input/read_time.f90
create mode 100644 forward/mathfuncs/alfa.f90
create mode 100644 forward/mathfuncs/amean.f90
create mode 100644 forward/mathfuncs/interpolate_lin.f90
create mode 100644 forward/mathfuncs/interpolate_pol.f90
create mode 100644 forward/mathfuncs/mean3d.f90
create mode 100644 forward/mod_conc.f90
create mode 100644 forward/mod_data.f90
create mode 100644 forward/mod_flow.f90
create mode 100644 forward/mod_genrl.f90
create mode 100644 forward/mod_genrlc.f90
create mode 100644 forward/mod_linfos.f90
create mode 100644 forward/mod_temp.f90
create mode 100644 forward/mod_time.f90
create mode 100644 forward/model_init.f90
create mode 100644 forward/nlrelaxad.f90
create mode 100644 forward/no_ext_link.f90
create mode 100644 forward/old_restore.f90
create mode 100644 forward/old_save.f90
create mode 100644 forward/omp_bindtools.f90
create mode 100644 forward/omp_file_handler.f90
create mode 100644 forward/omp_libnuma.c
create mode 100644 forward/omp_summe.f90
create mode 100644 forward/output/write_data.f90
create mode 100644 forward/output/write_dense3d.f90
create mode 100644 forward/output/write_logs.f90
create mode 100644 forward/output/write_monitor.f90
create mode 100644 forward/output/write_outt.f90
create mode 100644 forward/output/write_status_log.f90
create mode 100644 forward/output/write_tecdiff.f90
create mode 100644 forward/output/write_tecplot.f90
create mode 100644 forward/output/write_tecplotc.f90
create mode 100644 forward/output/write_text.f90
create mode 100644 forward/output/write_vtk.f90
create mode 100644 forward/pres/calc_pres.f90
create mode 100644 forward/pres/neumann_pres.f90
create mode 100644 forward/pres/omp_pres2head.f90
create mode 100644 forward/pres/pbuoy.f90
create mode 100644 forward/pres/pfluxes.f90
create mode 100644 forward/pres/pres2head.f90
create mode 100644 forward/pres/pstor.f90
create mode 100644 forward/pres/set_pbc.f90
create mode 100644 forward/pres/set_pcoef.f90
create mode 100644 forward/pres/set_pq.f90
create mode 100644 forward/save_data.f90
create mode 100644 forward/set_tsal.f90
create mode 100644 forward/set_var_deltat.f90
create mode 100644 forward/shemach/compress_file.f90
create mode 100644 forward/shemach/sys_cputime.f90
create mode 100644 forward/shemach/sys_mkdir.f90
create mode 100644 forward/stab_param.f90
create mode 100644 forward/static_relaxation.f90
create mode 100644 forward/strngut/beginlast.f90
create mode 100644 forward/strngut/cfirst.f90
create mode 100644 forward/strngut/chln.f90
create mode 100644 forward/strngut/clast.f90
create mode 100644 forward/strngut/found.f90
create mode 100644 forward/strngut/get_arg.f90
create mode 100644 forward/strngut/lblank.f90
create mode 100644 forward/strngut/locstr.f90
create mode 100644 forward/strngut/sfirst.f90
create mode 100644 forward/temp/calc_temp.f90
create mode 100644 forward/temp/neumann_temp.f90
create mode 100644 forward/temp/peclet_temp.f90
create mode 100644 forward/temp/set_tbc.f90
create mode 100644 forward/temp/set_tcoef.f90
create mode 100644 forward/temp/set_tq.f90
create mode 100644 forward/temp/tfluxes.f90
create mode 100644 forward/test_opt.f90
create mode 100644 hdf5/close_hdf5.f90
create mode 100644 hdf5/closeopen_hdf5.f90
create mode 100644 hdf5/mod_hdf5_vars.f90
create mode 100644 hdf5/mod_input_file_parser_hdf5.f90
create mode 100644 hdf5/open_hdf5.f90
create mode 100644 hdf5/read_hdf5.f90
create mode 100644 hdf5/read_hdf5_int.f90
create mode 100644 hdf5/test_hdf5.f90
create mode 100644 hdf5/write_all_hdf5.f90
create mode 100644 props/bas/check_domain.f90
create mode 100644 props/bas/compf.f90
create mode 100644 props/bas/compm.f90
create mode 100644 props/bas/cpf.f90
create mode 100644 props/bas/disp.f90
create mode 100644 props/bas/kx.f90
create mode 100644 props/bas/ky.f90
create mode 100644 props/bas/kz.f90
create mode 100644 props/bas/lamf.f90
create mode 100644 props/bas/lamm.f90
create mode 100644 props/bas/lx.f90
create mode 100644 props/bas/ly.f90
create mode 100644 props/bas/lz.f90
create mode 100644 props/bas/por.f90
create mode 100644 props/bas/props_check.f90
create mode 100644 props/bas/props_end.f90
create mode 100644 props/bas/props_init.f90
create mode 100644 props/bas/qc.f90
create mode 100644 props/bas/qf.f90
create mode 100644 props/bas/qt.f90
create mode 100644 props/bas/rce.f90
create mode 100644 props/bas/read_props.f90
create mode 100644 props/bas/rhocf.f90
create mode 100644 props/bas/rhocm.f90
create mode 100644 props/bas/rhof.f90
create mode 100644 props/bas/visf.f90
create mode 100644 props/basc/check_domain.f90
create mode 100644 props/basc/compf.f90
create mode 100644 props/basc/compm.f90
create mode 100644 props/basc/compw.f90
create mode 100644 props/basc/cpf.f90
create mode 100644 props/basc/cpw.f90
create mode 100644 props/basc/disp.f90
create mode 100644 props/basc/kx.f90
create mode 100644 props/basc/ky.f90
create mode 100644 props/basc/kz.f90
create mode 100644 props/basc/lamf.f90
create mode 100644 props/basc/lamm.f90
create mode 100644 props/basc/lamw.f90
create mode 100644 props/basc/lx.f90
create mode 100644 props/basc/ly.f90
create mode 100644 props/basc/lz.f90
create mode 100644 props/basc/por.f90
create mode 100644 props/basc/props_check.f90
create mode 100644 props/basc/props_end.f90
create mode 100644 props/basc/props_init.f90
create mode 100644 props/basc/qc.f90
create mode 100644 props/basc/qf.f90
create mode 100644 props/basc/qt.f90
create mode 100644 props/basc/rce.f90
create mode 100644 props/basc/read_props.f90
create mode 100644 props/basc/rhocf.f90
create mode 100644 props/basc/rhocm.f90
create mode 100644 props/basc/rhof.f90
create mode 100644 props/basc/rhow.f90
create mode 100644 props/basc/visf.f90
create mode 100644 props/basc/visw.f90
create mode 100644 props/const/check_domain.f90
create mode 100644 props/const/compf.f90
create mode 100644 props/const/compm.f90
create mode 100644 props/const/cpf.f90
create mode 100644 props/const/disp.f90
create mode 100644 props/const/kx.f90
create mode 100644 props/const/ky.f90
create mode 100644 props/const/kz.f90
create mode 100644 props/const/lamf.f90
create mode 100644 props/const/lx.f90
create mode 100644 props/const/ly.f90
create mode 100644 props/const/lz.f90
create mode 100644 props/const/mod_const.f90
create mode 100644 props/const/por.f90
create mode 100644 props/const/props_check.f90
create mode 100644 props/const/props_end.f90
create mode 100644 props/const/props_init.f90
create mode 100644 props/const/qc.f90
create mode 100644 props/const/qf.f90
create mode 100644 props/const/qt.f90
create mode 100644 props/const/rce.f90
create mode 100644 props/const/read_props.f90
create mode 100644 props/const/rhocf.f90
create mode 100644 props/const/rhocm.f90
create mode 100644 props/const/rhof.f90
create mode 100644 props/const/visf.f90
create mode 100644 props/ghe/check_domain.f90
create mode 100644 props/ghe/compf.f90
create mode 100644 props/ghe/compm.f90
create mode 100644 props/ghe/cpf.f90
create mode 100644 props/ghe/disp.f90
create mode 100644 props/ghe/ghe_array.f90
create mode 100644 props/ghe/ghe_hpr.f90
create mode 100644 props/ghe/kx.f90
create mode 100644 props/ghe/ky.f90
create mode 100644 props/ghe/kz.f90
create mode 100644 props/ghe/lamf.f90
create mode 100644 props/ghe/lamm.f90
create mode 100644 props/ghe/lx.f90
create mode 100644 props/ghe/ly.f90
create mode 100644 props/ghe/lz.f90
create mode 100644 props/ghe/por.f90
create mode 100644 props/ghe/props_check.f90
create mode 100644 props/ghe/props_end.f90
create mode 100644 props/ghe/props_init.f90
create mode 100644 props/ghe/qc.f90
create mode 100644 props/ghe/qf.f90
create mode 100644 props/ghe/qt.f90
create mode 100644 props/ghe/rce.f90
create mode 100644 props/ghe/read_props.f90
create mode 100644 props/ghe/rhocf.f90
create mode 100644 props/ghe/rhocm.f90
create mode 100644 props/ghe/rhof.f90
create mode 100644 props/ghe/visf.f90
create mode 100644 props/ice/check_domain.f90
create mode 100644 props/ice/compf.f90
create mode 100644 props/ice/compm.f90
create mode 100644 props/ice/compw.f90
create mode 100644 props/ice/cpf.f90
create mode 100644 props/ice/cpi.f90
create mode 100644 props/ice/disp.f90
create mode 100644 props/ice/ftheta.f90
create mode 100644 props/ice/ice.f90
create mode 100644 props/ice/ice.inc
create mode 100644 props/ice/ice_allocate.f90
create mode 100644 props/ice/kx.f90
create mode 100644 props/ice/ky.f90
create mode 100644 props/ice/kz.f90
create mode 100644 props/ice/lamf.f90
create mode 100644 props/ice/lami.f90
create mode 100644 props/ice/lamm.f90
create mode 100644 props/ice/lx.f90
create mode 100644 props/ice/ly.f90
create mode 100644 props/ice/lz.f90
create mode 100644 props/ice/por.f90
create mode 100644 props/ice/props_check.f90
create mode 100644 props/ice/props_init.f90
create mode 100644 props/ice/qc.f90
create mode 100644 props/ice/qf.f90
create mode 100644 props/ice/qt.f90
create mode 100644 props/ice/rce.f90
create mode 100644 props/ice/read_props.f90
create mode 100644 props/ice/rhocf.f90
create mode 100644 props/ice/rhoci.f90
create mode 100644 props/ice/rhocm.f90
create mode 100644 props/ice/rhof.f90
create mode 100644 props/ice/rhoi.f90
create mode 100644 props/ice/rhow.f90
create mode 100644 props/ice/visf.f90
create mode 100644 shem_fw.f90
create mode 100644 solve/CMakeLists.txt
create mode 100644 solve/OMP_TOOLS.f90
create mode 100644 solve/OMP_TOOLS.inc
create mode 100644 solve/counter.f90
create mode 100644 solve/ddl_du.f90
create mode 100644 solve/dense_solve.f90
create mode 100644 solve/direct_solve.f90
create mode 100644 solve/get_dnorm.f90
create mode 100644 solve/get_norm.f90
create mode 100644 solve/get_norm2.f90
create mode 100644 solve/mod_OMP_TOOLS.f90
create mode 100644 solve/mod_blocking_size.f90
create mode 100644 solve/norm_linsys.f90
create mode 100644 solve/norm_linsys2.f90
create mode 100644 solve/norm_resid.f90
create mode 100644 solve/omp_abbruch.f90
create mode 100644 solve/omp_bayes_solve.f90
create mode 100644 solve/omp_damax.f90
create mode 100644 solve/omp_ddot.f90
create mode 100644 solve/omp_gen_solve.f90
create mode 100644 solve/omp_gen_solve_diag.f90
create mode 100644 solve/omp_gen_solve_ilu.f90
create mode 100644 solve/omp_gen_solve_ssor.f90
create mode 100644 solve/omp_mvp.f90
create mode 100644 solve/omp_mvp2.f90
create mode 100644 solve/omp_preconditioners.f90
create mode 100644 solve/omp_sym_solve.f90
create mode 100644 solve/omp_sym_solve_diag.f90
create mode 100644 solve/omp_sym_solve_ilu.f90
create mode 100644 solve/omp_sym_solve_ssor.f90
create mode 100644 solve/p_pos_anz.f90
create mode 100644 solve/par_tools.f90
create mode 100644 solve/pre_bicgstab.f90
create mode 100644 solve/pre_bicgstab.inc
create mode 100644 solve/pre_cg.f90
create mode 100644 solve/pre_cg.inc
create mode 100644 solve/preconditioners.f90
create mode 100644 solve/prepare_solve.f90
create mode 100644 solve/qddot.f90
create mode 100644 solve/reduction.f90
create mode 100644 solve/set_dval.f90
create mode 100644 solve/set_ival.f90
create mode 100644 solve/set_lval.f90
create mode 100644 solve/solve.f90
create mode 100644 solve/solve_debug.f90
create mode 100644 solve/solve_type.f90
create mode 100644 solve/ssor_mvp_single.f90
create mode 100644 solve/test_matrix.f90
create mode 100644 solve/test_symmetry.f90
create mode 100644 solve/test_zero.f90
create mode 100644 user/none/calc_user.f90
create mode 100644 user/none/user_check.f90
create mode 100644 user/none/write_monitor_user.f90
create mode 100644 user/none/write_user.f90
create mode 100644 user/wells3d/calc_user.f90
create mode 100644 user/wells3d/mod_wells3d.f90
create mode 100644 user/wells3d/user_check.f90
create mode 100644 user/wells3d/write_monitor_user.f90
create mode 100644 user/wells3d/write_user.f90
create mode 100644 version.inc.in
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..21a29a4
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,6 @@
+Makefile.dep
+Makefile.flags
+version.inc
+test_integer.exe
+*.mod
+*.o
\ No newline at end of file
diff --git a/.gitlab/issue_templates/Error.md b/.gitlab/issue_templates/Error.md
new file mode 100644
index 0000000..cadfb28
--- /dev/null
+++ b/.gitlab/issue_templates/Error.md
@@ -0,0 +1,23 @@
+Error message
+-------------
+```
+(Insert Error message here)
+```
+
+Error Description
+-----------------
+(Concisely describe the error here.)
+
+Gitlab Branch
+-------------
+`(Insert Gitlab branch)`
+
+Status Log
+----------
+```
+(Insert MODELNAME_status.log)
+```
+or (even better)
+```
+(Insert Makefile.flags - generated during compilation)
+```
diff --git a/CMakeLists.txt b/CMakeLists.txt
new file mode 100644
index 0000000..c79e718
--- /dev/null
+++ b/CMakeLists.txt
@@ -0,0 +1,93 @@
+# MIT License
+#
+# Copyright (c) 2020 SHEMAT-Suite
+#
+# Permission is hereby granted, free of charge, to any person obtaining a copy
+# of this software and associated documentation files (the "Software"), to deal
+# in the Software without restriction, including without limitation the rights
+# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+# copies of the Software, and to permit persons to whom the Software is
+# furnished to do so, subject to the following conditions:
+#
+# The above copyright notice and this permission notice shall be included in all
+# copies or substantial portions of the Software.
+#
+# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+# SOFTWARE.
+
+cmake_minimum_required(VERSION 3.12 FATAL_ERROR)
+project(SHEMAT-Suite VERSION 9.00 DESCRIPTION "Freely" LANGUAGES Fortran)
+
+enable_language(Fortran C CXX)
+set(CMAKE_MODULE_PATH ${CMAKE_MODULE_PATH} ${CMAKE_CURRENT_LIST_DIR}/cmake/)
+
+# Executable sources
+file(GLOB SRC_MAIN_FW shem_fw.f90)
+file(GLOB SRC_MAIN_AD shem_ad.f90)
+file(GLOB SRC_MAIN_DD shem_dd.f90)
+file(GLOB SRC_MAIN_SM shem_sm.f90)
+
+
+include(cmake/Options.cmake)
+include(cmake/Sources.cmake)
+include(cmake/Flags.cmake)
+include(cmake/Packages.cmake)
+include(cmake/Dependencies.cmake)
+include(cmake/AD.cmake)
+
+
+
+set(FW_NAME "shem_fw_${PROPS}.x")
+add_executable(${FW_NAME} ${SRC_MAIN_FW} ${SRC_FORWARD})
+
+set(AD_NAME "shem_ad_${PROPS}.x")
+add_executable(${AD_NAME} EXCLUDE_FROM_ALL ${SRC_MAIN_AD} ${SRC_INVERSE})
+
+set(DD_NAME "shem_dd_${PROPS}.x")
+add_executable(${DD_NAME} EXCLUDE_FROM_ALL ${SRC_MAIN_DD} ${SRC_INVERSE})
+
+set(SM_NAME "shem_sm_${PROPS}.x")
+add_executable(${SM_NAME} EXCLUDE_FROM_ALL ${SRC_MAIN_SM} ${SRC_SIMUL})
+
+# Library Sources
+file(GLOB SRC_LIB_SHEMAT shem_fl.f90)
+file(GLOB SRC_LIB_SHEMAT_PARAMETER shem_parameter.f90)
+
+#Shortcut Make Targets
+add_custom_target(fw DEPENDS ${FW_NAME})
+add_custom_target(ad DEPENDS ${AD_NAME})
+add_custom_target(dd DEPENDS ${DD_NAME})
+add_custom_target(sm DEPENDS ${SM_NAME})
+
+target_compile_definitions(${AD_NAME} PUBLIC -DAD -Dset${ADTYPE})
+if (NOT ${NLSOLVETYPE} MATCHES "stdFW")
+ target_compile_definitions(${FW_NAME} PUBLIC -D${NLSOLVETYPE} -DAD -Dset${ADTYPE})
+ target_include_directories(${FW_NAME} PUBLIC nonlinear/nitsol/Nitsol)
+else()
+ add_definitions(-DstdFW)
+endif()
+
+
+if(use_rm)
+ target_compile_definitions(${AD_NAME} PUBLIC -DJACOBI_FREE -DAD_RM -Dset${AD_RMTYPE})
+endif()
+target_compile_definitions(${DD_NAME} PUBLIC -DAD -Dset${ADTYPE})
+
+
+add_library("shemat_oed" EXCLUDE_FROM_ALL ${SRC_LIB_SHEMAT} ${SRC_INVERSE} ${SRC_BLAS} ${SRC_LAPACK})
+target_compile_definitions("shemat_oed" PUBLIC -DAD -Dset${ADTYPE})
+target_compile_options("shemat_oed" PUBLIC -fPIC)
+
+
+add_library("shemat_parameter" EXCLUDE_FROM_ALL ${SRC_LIB_SHEMAT_PARAMETER} ${SRC_INVERSE} ${SRC_BLAS} ${SRC_LAPACK})
+target_compile_definitions("shemat_parameter" PUBLIC -DMF_STBAY -DAD -Dset${ADTYPE} -Dmatvec -DAD_RM -DJACOBI_FREE)
+target_compile_options("shemat_parameter" PUBLIC -fPIC)
+
+
+add_custom_target(lib_oed DEPENDS "shemat_oed")
+add_custom_target(lib_parameter DEPENDS "shemat_parameter")
diff --git a/LICENSE.md b/LICENSE.md
new file mode 100644
index 0000000..a5a7f74
--- /dev/null
+++ b/LICENSE.md
@@ -0,0 +1,21 @@
+MIT License
+
+Copyright (c) 2020 SHEMAT-Suite
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
diff --git a/cmake/AD.cmake b/cmake/AD.cmake
new file mode 100644
index 0000000..355a1d4
--- /dev/null
+++ b/cmake/AD.cmake
@@ -0,0 +1,148 @@
+# MIT License
+#
+# Copyright (c) 2020 SHEMAT-Suite
+#
+# Permission is hereby granted, free of charge, to any person obtaining a copy
+# of this software and associated documentation files (the "Software"), to deal
+# in the Software without restriction, including without limitation the rights
+# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+# copies of the Software, and to permit persons to whom the Software is
+# furnished to do so, subject to the following conditions:
+#
+# The above copyright notice and this permission notice shall be included in all
+# copies or substantial portions of the Software.
+#
+# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+# SOFTWARE.
+
+# Standard AD USER and PROPS
+set(USERS_PROP "basc")
+set(PROPS_USER "wells3d")
+
+# AD Forward targets
+#===================
+add_custom_target(ad_exports
+ COMMAND
+ export forward_lst="${AD_DIRECTORIES}"; export users_lst="${USER_DIRECTORIES}"; export props_lst="${PROPS_DIRECTORIES}"; export props_user="${USERS_PROP}";export users_prop="${PROPS_USER}"
+ WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}/mkAD
+ COMMENT
+ "export the propper ad bash variables"
+)
+
+add_custom_target(tap_tlm_users_prepare
+ DEPENDS ad_exports
+ COMMAND
+ make TOOL=tap phys_base='${phys_base}' ad_mode='full' users_lst='${USER_DIRECTORIES}' props_lst='${USERS_PROP}' forward_lst='${AD_DIRECTORIES}' prepare
+WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}/mkAD
+ COMMENT
+ "prepare user functions for automatic differentiation with tapenade"
+)
+
+
+add_custom_target(tap_tlm_users_tlm
+ DEPENDS tap_tlm_users_prepare
+ COMMAND
+ make TOOL=tap phys_base='${phys_base}' ad_mode='full' users_lst='${USER_DIRECTORIES}' props_lst='${USERS_PROP}' forward_lst='${AD_DIRECTORIES}' tlm
+ WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}/mkAD
+ COMMENT
+ "execute user automatic differentiation with tapenade and copy the results"
+)
+
+add_custom_target(tap_tlm_props_prepare
+ DEPENDS tap_tlm_users_tlm
+ COMMAND
+ make TOOL=tap phys_base='${phys_base}' ad_mode='full' users_lst='${PROPS_USER}' props_lst='${PROPS_DIRECTORIES}' forward_lst='${AD_DIRECTORIES}' prepare
+ #echo "TOOL=tap phys_base='${phys_base}' ad_mode='full' users_lst='${USER}' props_lst='${USERS_PROP}' forward_lst='${AD_DIRECTORIES}' prepare"
+WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}/mkAD
+ COMMENT
+ "prepare props functions for automatic differentiation with tapenade"
+)
+
+
+add_custom_target(tap_tlm_props_tlm
+ DEPENDS tap_tlm_props_prepare
+ COMMAND
+ make TOOL=tap phys_base='${phys_base}' ad_mode='full' users_lst='${PROPS_USER}' props_lst='${PROPS_DIRECTORIES}' forward_lst='${AD_DIRECTORIES}' tlm
+ WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}/mkAD
+ COMMENT
+ "execute props automatic differentiation with tapenade and copy results"
+)
+add_custom_target(tap_tlm
+ DEPENDS tap_tlm_props_tlm
+ COMMAND
+ export forward_lst="${AD_DIRECTORIES}" users_lst="${USER_DIRECTORIES}" props_lst="${PROPS_DIRECTORIES}" props_user="${PROPS_USER}" users_prop=${USERS_PROP} phys_base="${phys_base}" &&
+ ./mkAD/mv_tap_tlm &&
+ rm user/none/g_tap/${phys_base}/calc_user_ftl.f90 &&
+ rm -fr g_tap/${phys_base}/*_nodiff.f* g_tap/${phys_base}/daxpy_ftl.f* g_tap/${phys_base}/dcopy_ftl.f* g_tap/${phys_base}/dscal_ftl.f* props/*/g_tap/${phys_base}/*_nodiff*.* user/*/g_tap/${phys_base}/*_nodiff*.f90
+ WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}
+ COMMENT "AD Differentiation with Tapenade"
+ )
+
+add_custom_target(tap_tlm_clean
+ COMMAND
+ rm -fr ${CMAKE_CURRENT_SOURCE_DIR}/props/*/g_tap/${phys_base} ${CMAKE_CURRENT_SOURCE_DIR}/user/*/g_tap/${phys_base} ${CMAKE_CURRENT_SOURCE_DIR}/g_tap/${phys_base}
+ COMMENT "Cleaning Tapenade TLM directories"
+ )
+
+
+# AD Reverse targets
+#===================
+add_custom_target(tap_adm_users_prepare
+ DEPENDS ad_exports
+ COMMAND
+ make TOOL=tap phys_base='${phys_base}' ad_mode='full' users_lst='${USER_DIRECTORIES}' props_lst='${USERS_PROP}' forward_lst='${AD_DIRECTORIES}' prepare_reverse
+WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}/mkAD
+ COMMENT
+ "prepare user functions for automatic differentiation with tapenade"
+)
+
+
+add_custom_target(tap_adm_users_adm
+ DEPENDS tap_adm_users_prepare
+ COMMAND
+ make TOOL=tap phys_base='${phys_base}' ad_mode='full' users_lst='${USER_DIRECTORIES}' props_lst='${USERS_PROP}' forward_lst='${AD_DIRECTORIES}' adm
+ WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}/mkAD
+ COMMENT
+ "execute user automatic differentiation with tapenade and copy the results"
+)
+
+add_custom_target(tap_adm_props_prepare
+ DEPENDS tap_adm_users_adm
+ COMMAND
+ make TOOL=tap phys_base='${phys_base}' ad_mode='full' users_lst='${PROPS_USER}' props_lst='${PROPS_DIRECTORIES}' forward_lst='${AD_DIRECTORIES}' prepare_reverse
+ #echo "TOOL=tap phys_base='${phys_base}' ad_mode='full' users_lst='${USER}' props_lst='${USERS_PROP}' forward_lst='${AD_DIRECTORIES}' prepare"
+WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}/mkAD
+ COMMENT
+ "prepare props functions for automatic differentiation with tapenade"
+)
+
+
+add_custom_target(tap_adm_props_adm
+ DEPENDS tap_adm_props_prepare
+ COMMAND
+ make TOOL=tap phys_base='${phys_base}' ad_mode='full' users_lst='${PROPS_USER}' props_lst='${PROPS_DIRECTORIES}' forward_lst='${AD_DIRECTORIES}' adm
+ WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}/mkAD
+ COMMENT
+ "execute props automatic differentiation with tapenade and copy results"
+)
+add_custom_target(tap_adm
+ DEPENDS tap_adm_props_adm
+ COMMAND
+ export forward_lst="${AD_DIRECTORIES}" users_lst="${USER_DIRECTORIES}" props_lst="${PROPS_DIRECTORIES}" props_user="${PROPS_USER}" users_prop=${USERS_PROP} phys_base="${phys_base}" &&
+ ./mkAD/mv_tap_adm #&&
+ #rm user/none/ad_tap/ad_calc_user.f90 &&
+ #rm -fr ad_tap/*_nodiff.f* ad_tap/daxpy_ftl.f* ad_tap/dcopy_ftl.f* ad_tap/dscal_ftl.f* props/*/ad_tap/*_nodiff.* user/*/ad_tap/*_nodiff.f90
+ WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}
+ COMMENT "AD Differentiation with Tapenade"
+ )
+
+add_custom_target(tap_adm_clean
+ COMMAND
+ rm -fr ${CMAKE_CURRENT_SOURCE_DIR}/props/*/ad_tap/${phys_base}\${CMAKE_CURRENT_SOURCE_DIR}/user/*/ad_tap/${phys_base} ${CMAKE_CURRENT_SOURCE_DIR}/ad_tap/${phys_base}
+ COMMENT "Cleaning Tapenade TLM directories"
+ )
diff --git a/cmake/Dependencies.cmake b/cmake/Dependencies.cmake
new file mode 100644
index 0000000..e8bca26
--- /dev/null
+++ b/cmake/Dependencies.cmake
@@ -0,0 +1,76 @@
+# MIT License
+#
+# Copyright (c) 2020 SHEMAT-Suite
+#
+# Permission is hereby granted, free of charge, to any person obtaining a copy
+# of this software and associated documentation files (the "Software"), to deal
+# in the Software without restriction, including without limitation the rights
+# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+# copies of the Software, and to permit persons to whom the Software is
+# furnished to do so, subject to the following conditions:
+#
+# The above copyright notice and this permission notice shall be included in all
+# copies or substantial portions of the Software.
+#
+# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+# SOFTWARE.
+
+#====================================================
+#Generate version.inc
+#====================================================
+string(TIMESTAMP _configuration_time "%Y-%m-%d %H:%M:%S [UTC]" UTC)
+configure_file(version.inc.in generated/version.inc @ONLY)
+#====================================================
+
+
+#====================================================
+#This section is for updating forward/input/read_check.f90 with newly implemented reading paramters
+#====================================================
+#Read all read_*.f90 files and put the parameter names in @read_cur_use
+FOREACH(fname ${read_files})
+ file(STRINGS ${fname} cur_file REGEX "^[^c^C^!].*found.*(\#|key_char//') [a-zA-Z0-9 _]+.*")
+ #message("${cur_file}")
+ foreach(str ${cur_file})
+ # message("str=${str}")
+ string(REGEX REPLACE ".*'(\#| )([a-zA-Z0-9_]*)(:|'| ).*" "\\2" cur ${str})
+ list(APPEND read_cur_use ${cur})
+ endforeach()
+ENDFOREACH()
+list(REMOVE_DUPLICATES read_cur_use)
+list(SORT read_cur_use)
+
+#Read all parameters we are currently checking in read_check.f90, store them in @read_check_use
+file(STRINGS forward/input/read_check.f90 check_file_content REGEX "key_char//")
+foreach(str ${check_file_content})
+ string(REGEX REPLACE ".*'(\#| )([a-zA-Z0-9_]*)(:|'| ).*" "\\2" cur ${str})
+ list(APPEND read_check_use ${cur})
+endforeach()
+list(REMOVE_DUPLICATES read_check_use)
+list(SORT read_check_use)
+
+#Now remove all the parameters we are currently checking from the @read_cur_use list
+list(REMOVE_ITEM read_cur_use ${read_check_use})
+
+# Do we need to update read_check.f90 with missing parameters in read_cur_use?
+if (read_cur_use)
+ message("We have to update read_check.f90 with ${read_cur_use}")
+ file(STRINGS forward/input/read_check.f90 check_file_content)
+ set(automatic_section ${check_file_content})
+ list(FILTER automatic_section INCLUDE REGEX ".*automatic generated.*")
+ list(FIND check_file_content "${automatic_section}" automatic_element)
+ MATH(EXPR automatic_element "${automatic_element}+1")
+ foreach(item ${read_cur_use})
+ list(INSERT check_file_content ${automatic_element} " f_entry = f_entry + locstr(line,key_char\/\/' ${item}')")
+ MATH(EXPR automatic_element "${automatic_element}+1")
+ endforeach()
+ file(WRITE forward/input/read_check.f90 "")
+ foreach(str ${check_file_content})
+ file(APPEND forward/input/read_check.f90 "${str}\n")
+ endforeach()
+endif()
+#====================================================
diff --git a/cmake/Flags.cmake b/cmake/Flags.cmake
new file mode 100644
index 0000000..4736419
--- /dev/null
+++ b/cmake/Flags.cmake
@@ -0,0 +1,60 @@
+# MIT License
+#
+# Copyright (c) 2020 SHEMAT-Suite
+#
+# Permission is hereby granted, free of charge, to any person obtaining a copy
+# of this software and associated documentation files (the "Software"), to deal
+# in the Software without restriction, including without limitation the rights
+# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+# copies of the Software, and to permit persons to whom the Software is
+# furnished to do so, subject to the following conditions:
+#
+# The above copyright notice and this permission notice shall be included in all
+# copies or substantial portions of the Software.
+#
+# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+# SOFTWARE.
+
+if("${CMAKE_Fortran_COMPILER_ID}" MATCHES "Intel")
+ if (NOT debug)
+ add_compile_options(-w -O3 -vec_report0 -fpp -axSTPW -fp-model fast=2)
+ else()
+ add_compile_options(-g -O0 -fpp)
+ endif()
+elseif("${CMAKE_Fortran_COMPILER_ID}" MATCHES "GNU")
+ if (NOT debug)
+ add_compile_options(-fno-second-underscore -march=k8 -O3 -funroll-all-loops -fprefetch-loop-arrays -ffast-math -mno-ieee-fp -DG95 -DCLopt -frepack-arrays -ftree-vectorize -funit-at-a-time -cpp)
+ else()
+ add_compile_options(-g -O0 -DG95 -cpp)
+ endif()
+endif()
+add_definitions(-DUSE_QDDOT)
+
+
+if(NOT use_rm)
+ add_definitions(-DSTBAY)
+endif()
+
+if (head_base)
+ add_definitions(-Dhead_base)
+elseif(pres_base)
+ add_definitions(-Dpres_base)
+else()
+ message(FATAL_ERROR "head_base OR pres_base need to be set")
+endif()
+
+add_definitions(-DUSER_${USER} -DPROPS_${PROPS} -DSIMUL_${SIMUL} )
+
+if(NOT plt)
+ add_definitions(-DNOPLT)
+endif()
+
+if(NOT vtk)
+ add_definitions(-DNOVTK)
+endif()
+
diff --git a/cmake/Options.cmake b/cmake/Options.cmake
new file mode 100644
index 0000000..6c836b6
--- /dev/null
+++ b/cmake/Options.cmake
@@ -0,0 +1,73 @@
+# MIT License
+#
+# Copyright (c) 2020 SHEMAT-Suite
+#
+# Permission is hereby granted, free of charge, to any person obtaining a copy
+# of this software and associated documentation files (the "Software"), to deal
+# in the Software without restriction, including without limitation the rights
+# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+# copies of the Software, and to permit persons to whom the Software is
+# furnished to do so, subject to the following conditions:
+#
+# The above copyright notice and this permission notice shall be included in all
+# copies or substantial portions of the Software.
+#
+# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+# SOFTWARE.
+
+option(omp "OpenMP switch" ON)
+option(hdf "HDF5 switch" ON)
+option(mpi "MPI switch" OFF)
+option(plt "PLT switch" ON)
+option(vtk "VTK switch" ON)
+#option(head "Use head based computation" ON)
+#option(pres "Use pressure based computation" OFF)
+option(details "Show compilation details" OFF)
+option(debug "Compile with debug informations" OFF)
+option(use_rm "Use Reverse-Mode in Inversion" OFF)
+
+set(phys_base "head" CACHE INTERNAL "The used physical pressure representation, could be head or pres")
+set_property(CACHE phys_base PROPERTY STRINGS "head" "pres")
+message(STATUS "phys_base='${phys_base}'")
+
+set(USER "none" CACHE STRING "The Userfunction to be used (standard is none)")
+set(PROPS "const" CACHE STRING "The Properties to be used (standard is const)")
+
+
+# Solvertype for Nonlinear Coupling
+set(NLSOLVETYPE "stdFW" CACHE STRING "Nonlinear Solver")
+set_property(CACHE NLSOLVETYPE PROPERTY STRINGS "stdFW" "nwtFW" "nitFW")
+
+
+set(ADTYPE "g_tap" CACHE STRING "Used AD forward mode directories")
+set(AD_RMTYPE "ad_tap" CACHE STRING "Used AD reverse mode directories")
+
+set(SIMUL "sgsim" CACHE STRING "Used Simulation (sgsim)")
+if (${phys_base} MATCHES "pres")
+ set(pres_base ON)
+ set(head_base OFF)
+elseif(${phys_base} MATCHES "head")
+ set(head_base ON)
+ set(pres_base OFF)
+else()
+ message(FATAL_ERROR "phys_base needs to be set to head OR pres. Add -Dphys_base=head OR -Dphys_base=pres to cmake command [Standard is head]")
+endif()
+
+if(use_rm)
+ set(matfree ON)
+else()
+ set(matfree OFF)
+endif()
+
+if(details)
+ set(CMAKE_VERBOSE_MAKEFILE ON)
+endif()
+
+if(debug)
+ set(CMAKE_BUILD_TYPE Debug)
+endif()
diff --git a/cmake/Packages.cmake b/cmake/Packages.cmake
new file mode 100644
index 0000000..33a3003
--- /dev/null
+++ b/cmake/Packages.cmake
@@ -0,0 +1,41 @@
+# MIT License
+#
+# Copyright (c) 2020 SHEMAT-Suite
+#
+# Permission is hereby granted, free of charge, to any person obtaining a copy
+# of this software and associated documentation files (the "Software"), to deal
+# in the Software without restriction, including without limitation the rights
+# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+# copies of the Software, and to permit persons to whom the Software is
+# furnished to do so, subject to the following conditions:
+#
+# The above copyright notice and this permission notice shall be included in all
+# copies or substantial portions of the Software.
+#
+# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+# SOFTWARE.
+
+#packages
+if(omp)
+ find_package(OpenMP REQUIRED)
+ add_compile_options(${OpenMP_Fortran_FLAGS})
+ set(CMAKE_EXE_LINKER_FLAGS "${CMAKE_EXE_LINKER_FLAGS} ${OpenMP_Fortran_FLAGS}")
+ add_definitions(-DfOMP)
+endif()
+find_package(BLAS REQUIRED)
+link_libraries(${BLAS_LIBRARIES})
+find_package(LAPACK REQUIRED)
+link_libraries(${LAPACK_LIBRARIES})
+if(hdf)
+ find_package(HDF5 REQUIRED COMPONENTS Fortran Fortran_HL)
+ link_libraries(${HDF5_Fortran_LIBRARIES} ${HDF5_Fortran_HL_LIBRARIES})
+ include_directories(${HDF5_INCLUDE_DIRS})
+ add_definitions(-DHDF)
+else()
+ add_definitions(-DnoHDF)
+endif()
diff --git a/cmake/Sources.cmake b/cmake/Sources.cmake
new file mode 100644
index 0000000..24cf15b
--- /dev/null
+++ b/cmake/Sources.cmake
@@ -0,0 +1,137 @@
+# MIT License
+#
+# Copyright (c) 2020 SHEMAT-Suite
+#
+# Permission is hereby granted, free of charge, to any person obtaining a copy
+# of this software and associated documentation files (the "Software"), to deal
+# in the Software without restriction, including without limitation the rights
+# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+# copies of the Software, and to permit persons to whom the Software is
+# furnished to do so, subject to the following conditions:
+#
+# The above copyright notice and this permission notice shall be included in all
+# copies or substantial portions of the Software.
+#
+# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+# SOFTWARE.
+
+#Module Files - need to be build prior to all other files
+file (GLOB SRC_MODULES forward/arrays.f90 forward/mod_*.f90 solve/mod_*.f90 hdf5/mod_*.f90)
+file (GLOB SRC_MODULES_AD inverse/mod_*.f90 inverse/${ADTYPE}/g_arrays.f90 ${ADTYPE}/g_mod*.f* props/${PROPS}/${ADTYPE}/g_mod*.f*)
+file (GLOB SRC_MODULES_SM simul/mod_*.f90 simul/enkf/m_*.f*)
+
+#Forward Files
+file (GLOB SRC_FORWARD forward/*.f* forward/input/*.f* forward/output/*.f* forward/shemach/*.f* forward/strngut/*.f* forward/ctrlut/*.f*
+ forward/temp/*.f* forward/conc/*.f* forward/mathfuncs/*.f*)
+file (GLOB SRC_FORWARD_HEAD forward/head/*.f*)
+file (GLOB SRC_FORWARD_PRES forward/pres/*.f*)
+if (pres_base)
+ list(APPEND SRC_FORWARD ${SRC_FORWARD_PRES})
+elseif(head_base)
+ list(APPEND SRC_FORWARD ${SRC_FORWARD_HEAD})
+endif()
+
+
+#Inverse Files
+file(GLOB SRC_INVERSE inverse/*.f* inverse/${ADTYPE}/*.f* ${ADTYPE}/${phys_base}/*.f* blas/${ADTYPE}/*.f*)
+if (use_rm)
+ file(GLOB SRC_ADHELPER mkAD/ADFirstAidKit/adBuffer.f mkAD/ADFirstAidKit/adStack.c)
+ file(GLOB SRC_MODULES_AD_RM inverse/mod_*.f90 inverse/${AD_RMTYPE}/arrays_ad.f90 inverse/${AD_RMTYPE}/mod_*_ad.f* props/${PROPS}/${AD_RMTYPE}/${phys_base}/mod_*_ad.f*)
+ list(APPEND SRC_MODULES_AD ${SRC_MODULES_AD_RM})
+ file(GLOB SRC_INVERSE_RM inverse/${AD_RMTYPE}/* ${AD_RMTYPE}/${phys_base}/*.f* blas/${AD_RMTYPE}/*.f* props/${PROPS}/${AD_RMTYPE}/${phys_base}/*.f* user/${USER}/${AD_RMTYPE}/${phys_base}/*.f*)
+ list(APPEND SRC_INVERSE ${SRC_INVERSE_RM} ${SRC_ADHELPER})
+endif()
+
+#HDF FILES
+file(GLOB SRC_HDF hdf5/add_cube.f90 hdf5/open_hdf5.f90 hdf5/close_hdf5.f90 hdf5/closeopen_hdf5.f90 hdf5/test_hdf5.f90 hdf5/read_hdf5.f90 hdf5/read_hdf5_int.f90 hdf5/write_all_hdf5.f90 hdf5/add_line.f90 hdf5/write_parameter2_hdf5.f90 hdf5/add_plane.f90 hdf5/write_parameter_hdf5.f90 hdf5/read_outt_hdf5.f90 )
+#HDF FILES FOR INVERSE
+file(GLOB SRC_HDF_AD inverse/mod_inverse.f90 hdf5/write_joutt_hdf5.f90 hdf5/read_joutt_hdf5.f90 hdf5/write_inv_hdf5.f90 )
+
+
+#Solve Files
+file(GLOB SRC_SOLVE solve/counter.f90 solve/mod_blocking_size.f90 solve/omp_mvp2.f90 solve/omp_sym_solve_ilu.f90 solve/preconditioners.f90 solve/solve_debug.f90
+solve/ddl_du.f90 solve/mod_OMP_TOOLS.f90 solve/omp_damax.f90 solve/omp_mvp.f90 solve/omp_sym_solve_ssor.f90 solve/prepare_solve.f90 solve/solve.f90
+solve/dense_solve.f90 solve/nag_gen_solve.f90 solve/omp_ddot.f90 solve/OMP_TOOLS.f90 solve/qddot.f90 solve/solve_type.f90
+solve/direct_solve.f90 solve/norm_linsys2.f90 solve/omp_gen_solve_diag.f90 solve/par_tools.f90 solve/reduction.f90 solve/ssor_mvp_single.f90
+solve/get_dnorm.f90 solve/norm_linsys.f90 solve/omp_gen_solve.f90 solve/omp_preconditioners.f90 solve/p_pos_anz.f90 solve/set_dval.f90 solve/test_matrix.f90
+solve/get_norm2.f90 solve/norm_resid.f90 solve/omp_gen_solve_ilu.f90 solve/omp_sym_solve_diag.f90 solve/pre_bicgstab.f90 solve/set_ival.f90 solve/test_symmetry.f90
+solve/get_norm.f90 solve/omp_abbruch.f90 solve/omp_gen_solve_ssor.f90 solve/omp_sym_solve.f90 solve/pre_cg.f90 solve/set_lval.f90 solve/test_zero.f90 )
+
+file(GLOB SRC_SOLVE_AD solve/omp_bayes_solve.f90)
+
+#Simul Files
+file(GLOB SRC_SIMUL simul/*.f* simul/enkf/*.f* simul/gs/*.f* simul/${SIMUL}/*.f*)
+
+#User Files
+file(GLOB SRC_USER user/${USER}/*.f*)
+file(GLOB SRC_USER_AD user/${USER}/${ADTYPE}/${phys_base}/*.f*)
+
+#Props Files
+file(GLOB SRC_PROPS props/${PROPS}/*.f*)
+list(FILTER SRC_PROPS EXCLUDE REGEX ".*gps\_.*\.f*$")
+file(GLOB SRC_PROPS_AD props/${PROPS}/${ADTYPE}/${phys_base}/*.f*)
+
+
+# Include Directories
+include_directories("." "forward" "solve" "${PROJECT_BINARY_DIR}/generated/")
+
+
+#Sources for Forward Build
+list(APPEND SRC_FORWARD ${SRC_SOLVE} ${SRC_HDF} ${SRC_PROPS} ${SRC_USER} ${SRC_MODULES})
+
+#Sources for Inverse Build
+list(APPEND SRC_INVERSE ${SRC_FORWARD} ${SRC_HDF_AD} ${SRC_MODULES_AD} ${SRC_USER_AD} ${SRC_PROPS_AD} ${SRC_SOLVE_AD})
+if(pres_base)
+ list(FILTER SRC_INVERSE EXCLUDE REGEX ".*\_unconf.*\.f*$")
+endif()
+if(NOT ${NLSOLVETYPE} MATCHES "stdFW")
+ list(APPEND SRC_FORWARD ${SRC_NONLINEAR} ${SRC_INVERSE})
+endif()
+
+
+
+list(APPEND SRC_SIMUL ${SRC_FORWARD} ${SRC_MODULES_SM})
+
+file(GLOB read_files */read_*.f* */input/read_*.f* props/*/read_user.f*)
+list(FILTER read_files EXCLUDE REGEX ".*forward/input/read_check.f90|.*/input/read_restartFW.f90|.*inverse/read_restartINV.f90")
+
+
+# External library definitions to be used with e.g. EFCOSS
+#BLAS Files
+file(GLOB SRC_BLAS blas/*.f*)
+
+#LAPACK Files
+file(GLOB SRC_LAPACK lapack/*.f*)
+
+
+#Directories needed for AD generation
+list(APPEND AD_DIRECTORIES forward forward/input forward/output forward/shemach forward/strngut forward/ctrlut
+ forward/temp forward/conc forward/mathfuncs hdf5 solve blas)
+if(pres)
+ list(APPEND AD_DIRECTORIES forward/pres)
+else()
+ list(APPEND AD_DIRECTORIES forward/head)
+endif()
+
+# Define user and property directories for AD generation process (wells3d and basc are required, c.f AD.cmake)
+list(APPEND USER_DIRECTORIES wells3d none)# gheexpl)# wells wells6 wells3d_s3w wells3dN_CK wells3dN_CK3B wells3d_fine wells3d_stoch wells3d_stoch_3B wells3d_stoch_s3w gheloop gheexpl)
+list(APPEND PROPS_DIRECTORIES basc const bas)# ice kola)# conv basd frac ice kola)
+
+list(APPEND USER_DIRECTORIES_FULL USER_DIRECTORIES)
+list(APPEND PROPS_DIRECTORIES_FULL PROPS_DIRECTORIES)
+list(TRANSFORM USER_DIRECTORIES_FULL PREPEND "user/")
+list(TRANSFORM PROPS_DIRECTORIES_FULL PREPEND "props/")
+
+
+# All the directories for USER and PROPS variables
+file(GLOB ALL_USER_DIRECTORIES RELATIVE ${CMAKE_CURRENT_SOURCE_DIR}/user user/*)
+message(STATUS "Available USER='${ALL_USER_DIRECTORIES}'")
+file(GLOB ALL_PROPS_DIRECTORIES RELATIVE ${CMAKE_CURRENT_SOURCE_DIR}/props props/*)
+message(STATUS "Available PROPS='${ALL_PROPS_DIRECTORIES}'")
+set_property(CACHE USER PROPERTY STRINGS ${ALL_USER_DIRECTORIES})
+set_property(CACHE PROPS PROPERTY STRINGS ${ALL_PROPS_DIRECTORIES})
diff --git a/doc/Doxyfile b/doc/Doxyfile
new file mode 100644
index 0000000..a74ddb7
--- /dev/null
+++ b/doc/Doxyfile
@@ -0,0 +1,2327 @@
+# Doxyfile 1.8.5
+
+# This file describes the settings to be used by the documentation system
+# doxygen (www.doxygen.org) for a project.
+#
+# All text after a double hash (##) is considered a comment and is placed in
+# front of the TAG it is preceding.
+#
+# All text after a single hash (#) is considered a comment and will be ignored.
+# The format is:
+# TAG = value [value, ...]
+# For lists, items can also be appended using:
+# TAG += value [value, ...]
+# Values that contain spaces should be placed between quotes (\" \").
+
+#---------------------------------------------------------------------------
+# Project related configuration options
+#---------------------------------------------------------------------------
+
+# This tag specifies the encoding used for all characters in the config file
+# that follow. The default is UTF-8 which is also the encoding used for all text
+# before the first occurrence of this tag. Doxygen uses libiconv (or the iconv
+# built into libc) for the transcoding. See http://www.gnu.org/software/libiconv
+# for the list of possible encodings.
+# The default value is: UTF-8.
+
+DOXYFILE_ENCODING = UTF-8
+
+# The PROJECT_NAME tag is a single word (or a sequence of words surrounded by
+# double-quotes, unless you are using Doxywizard) that should identify the
+# project for which the documentation is generated. This name is used in the
+# title of most generated pages and in a few other places.
+# The default value is: My Project.
+
+PROJECT_NAME = Shemat-Suite
+
+# The PROJECT_NUMBER tag can be used to enter a project or revision number. This
+# could be handy for archiving the generated documentation or if some version
+# control system is used.
+
+PROJECT_NUMBER =
+
+# Using the PROJECT_BRIEF tag one can provide an optional one line description
+# for a project that appears at the top of each page and should give viewer a
+# quick idea about the purpose of the project. Keep the description short.
+
+PROJECT_BRIEF =
+
+# With the PROJECT_LOGO tag one can specify an logo or icon that is included in
+# the documentation. The maximum height of the logo should not exceed 55 pixels
+# and the maximum width should not exceed 200 pixels. Doxygen will copy the logo
+# to the output directory.
+
+PROJECT_LOGO =
+
+# The OUTPUT_DIRECTORY tag is used to specify the (relative or absolute) path
+# into which the generated documentation will be written. If a relative path is
+# entered, it will be relative to the location where doxygen was started. If
+# left blank the current directory will be used.
+
+OUTPUT_DIRECTORY = sources/
+
+# If the CREATE_SUBDIRS tag is set to YES, then doxygen will create 4096 sub-
+# directories (in 2 levels) under the output directory of each output format and
+# will distribute the generated files over these directories. Enabling this
+# option can be useful when feeding doxygen a huge amount of source files, where
+# putting all generated files in the same directory would otherwise causes
+# performance problems for the file system.
+# The default value is: NO.
+
+CREATE_SUBDIRS = YES
+
+# The OUTPUT_LANGUAGE tag is used to specify the language in which all
+# documentation generated by doxygen is written. Doxygen will use this
+# information to generate all constant output in the proper language.
+# Possible values are: Afrikaans, Arabic, Brazilian, Catalan, Chinese, Chinese-
+# Traditional, Croatian, Czech, Danish, Dutch, English, Esperanto, Farsi,
+# Finnish, French, German, Greek, Hungarian, Italian, Japanese, Japanese-en,
+# Korean, Korean-en, Latvian, Norwegian, Macedonian, Persian, Polish,
+# Portuguese, Romanian, Russian, Serbian, Slovak, Slovene, Spanish, Swedish,
+# Turkish, Ukrainian and Vietnamese.
+# The default value is: English.
+
+OUTPUT_LANGUAGE = English
+
+# If the BRIEF_MEMBER_DESC tag is set to YES doxygen will include brief member
+# descriptions after the members that are listed in the file and class
+# documentation (similar to Javadoc). Set to NO to disable this.
+# The default value is: YES.
+
+BRIEF_MEMBER_DESC = YES
+
+# If the REPEAT_BRIEF tag is set to YES doxygen will prepend the brief
+# description of a member or function before the detailed description
+#
+# Note: If both HIDE_UNDOC_MEMBERS and BRIEF_MEMBER_DESC are set to NO, the
+# brief descriptions will be completely suppressed.
+# The default value is: YES.
+
+REPEAT_BRIEF = NO
+
+# This tag implements a quasi-intelligent brief description abbreviator that is
+# used to form the text in various listings. Each string in this list, if found
+# as the leading text of the brief description, will be stripped from the text
+# and the result, after processing the whole list, is used as the annotated
+# text. Otherwise, the brief description is used as-is. If left blank, the
+# following values are used ($name is automatically replaced with the name of
+# the entity):The $name class, The $name widget, The $name file, is, provides,
+# specifies, contains, represents, a, an and the.
+
+ABBREVIATE_BRIEF = "The $name class" \
+ "The $name widget" \
+ "The $name file" \
+ is \
+ provides \
+ specifies \
+ contains \
+ represents \
+ a \
+ an \
+ the
+
+# If the ALWAYS_DETAILED_SEC and REPEAT_BRIEF tags are both set to YES then
+# doxygen will generate a detailed section even if there is only a brief
+# description.
+# The default value is: NO.
+
+ALWAYS_DETAILED_SEC = NO
+
+# If the INLINE_INHERITED_MEMB tag is set to YES, doxygen will show all
+# inherited members of a class in the documentation of that class as if those
+# members were ordinary class members. Constructors, destructors and assignment
+# operators of the base classes will not be shown.
+# The default value is: NO.
+
+INLINE_INHERITED_MEMB = NO
+
+# If the FULL_PATH_NAMES tag is set to YES doxygen will prepend the full path
+# before files name in the file list and in the header files. If set to NO the
+# shortest path that makes the file name unique will be used
+# The default value is: YES.
+
+FULL_PATH_NAMES = YES
+
+# The STRIP_FROM_PATH tag can be used to strip a user-defined part of the path.
+# Stripping is only done if one of the specified strings matches the left-hand
+# part of the path. The tag can be used to show relative paths in the file list.
+# If left blank the directory from which doxygen is run is used as the path to
+# strip.
+#
+# Note that you can specify absolute paths here, but also relative paths, which
+# will be relative from the directory where doxygen is started.
+# This tag requires that the tag FULL_PATH_NAMES is set to YES.
+
+STRIP_FROM_PATH = ../
+
+# The STRIP_FROM_INC_PATH tag can be used to strip a user-defined part of the
+# path mentioned in the documentation of a class, which tells the reader which
+# header file to include in order to use a class. If left blank only the name of
+# the header file containing the class definition is used. Otherwise one should
+# specify the list of include paths that are normally passed to the compiler
+# using the -I flag.
+
+STRIP_FROM_INC_PATH =
+
+# If the SHORT_NAMES tag is set to YES, doxygen will generate much shorter (but
+# less readable) file names. This can be useful is your file systems doesn't
+# support long names like on DOS, Mac, or CD-ROM.
+# The default value is: NO.
+
+SHORT_NAMES = NO
+
+# If the JAVADOC_AUTOBRIEF tag is set to YES then doxygen will interpret the
+# first line (until the first dot) of a Javadoc-style comment as the brief
+# description. If set to NO, the Javadoc-style will behave just like regular Qt-
+# style comments (thus requiring an explicit @brief command for a brief
+# description.)
+# The default value is: NO.
+
+JAVADOC_AUTOBRIEF = NO
+
+# If the QT_AUTOBRIEF tag is set to YES then doxygen will interpret the first
+# line (until the first dot) of a Qt-style comment as the brief description. If
+# set to NO, the Qt-style will behave just like regular Qt-style comments (thus
+# requiring an explicit \brief command for a brief description.)
+# The default value is: NO.
+
+QT_AUTOBRIEF = NO
+
+# The MULTILINE_CPP_IS_BRIEF tag can be set to YES to make doxygen treat a
+# multi-line C++ special comment block (i.e. a block of //! or /// comments) as
+# a brief description. This used to be the default behavior. The new default is
+# to treat a multi-line C++ comment block as a detailed description. Set this
+# tag to YES if you prefer the old behavior instead.
+#
+# Note that setting this tag to YES also means that rational rose comments are
+# not recognized any more.
+# The default value is: NO.
+
+MULTILINE_CPP_IS_BRIEF = NO
+
+# If the INHERIT_DOCS tag is set to YES then an undocumented member inherits the
+# documentation from any documented member that it re-implements.
+# The default value is: YES.
+
+INHERIT_DOCS = YES
+
+# If the SEPARATE_MEMBER_PAGES tag is set to YES, then doxygen will produce a
+# new page for each member. If set to NO, the documentation of a member will be
+# part of the file/class/namespace that contains it.
+# The default value is: NO.
+
+SEPARATE_MEMBER_PAGES = NO
+
+# The TAB_SIZE tag can be used to set the number of spaces in a tab. Doxygen
+# uses this value to replace tabs by spaces in code fragments.
+# Minimum value: 1, maximum value: 16, default value: 4.
+
+TAB_SIZE = 7
+
+# This tag can be used to specify a number of aliases that act as commands in
+# the documentation. An alias has the form:
+# name=value
+# For example adding
+# "sideeffect=@par Side Effects:\n"
+# will allow you to put the command \sideeffect (or @sideeffect) in the
+# documentation, which will result in a user-defined paragraph with heading
+# "Side Effects:". You can put \n's in the value part of an alias to insert
+# newlines.
+
+ALIASES =
+
+# This tag can be used to specify a number of word-keyword mappings (TCL only).
+# A mapping has the form "name=value". For example adding "class=itcl::class"
+# will allow you to use the command class in the itcl::class meaning.
+
+TCL_SUBST =
+
+# Set the OPTIMIZE_OUTPUT_FOR_C tag to YES if your project consists of C sources
+# only. Doxygen will then generate output that is more tailored for C. For
+# instance, some of the names that are used will be different. The list of all
+# members will be omitted, etc.
+# The default value is: NO.
+
+OPTIMIZE_OUTPUT_FOR_C = NO
+
+# Set the OPTIMIZE_OUTPUT_JAVA tag to YES if your project consists of Java or
+# Python sources only. Doxygen will then generate output that is more tailored
+# for that language. For instance, namespaces will be presented as packages,
+# qualified scopes will look different, etc.
+# The default value is: NO.
+
+OPTIMIZE_OUTPUT_JAVA = NO
+
+# Set the OPTIMIZE_FOR_FORTRAN tag to YES if your project consists of Fortran
+# sources. Doxygen will then generate output that is tailored for Fortran.
+# The default value is: NO.
+
+OPTIMIZE_FOR_FORTRAN = YES
+
+# Set the OPTIMIZE_OUTPUT_VHDL tag to YES if your project consists of VHDL
+# sources. Doxygen will then generate output that is tailored for VHDL.
+# The default value is: NO.
+
+OPTIMIZE_OUTPUT_VHDL = NO
+
+# Doxygen selects the parser to use depending on the extension of the files it
+# parses. With this tag you can assign which parser to use for a given
+# extension. Doxygen has a built-in mapping, but you can override or extend it
+# using this tag. The format is ext=language, where ext is a file extension, and
+# language is one of the parsers supported by doxygen: IDL, Java, Javascript,
+# C#, C, C++, D, PHP, Objective-C, Python, Fortran, VHDL. For instance to make
+# doxygen treat .inc files as Fortran files (default is PHP), and .f files as C
+# (default is Fortran), use: inc=Fortran f=C.
+#
+# Note For files without extension you can use no_extension as a placeholder.
+#
+# Note that for custom extensions you also need to set FILE_PATTERNS otherwise
+# the files are not read by doxygen.
+
+EXTENSION_MAPPING =
+
+# If the MARKDOWN_SUPPORT tag is enabled then doxygen pre-processes all comments
+# according to the Markdown format, which allows for more readable
+# documentation. See http://daringfireball.net/projects/markdown/ for details.
+# The output of markdown processing is further processed by doxygen, so you can
+# mix doxygen, HTML, and XML commands with Markdown formatting. Disable only in
+# case of backward compatibilities issues.
+# The default value is: YES.
+
+MARKDOWN_SUPPORT = YES
+
+# When enabled doxygen tries to link words that correspond to documented
+# classes, or namespaces to their corresponding documentation. Such a link can
+# be prevented in individual cases by by putting a % sign in front of the word
+# or globally by setting AUTOLINK_SUPPORT to NO.
+# The default value is: YES.
+
+AUTOLINK_SUPPORT = YES
+
+# If you use STL classes (i.e. std::string, std::vector, etc.) but do not want
+# to include (a tag file for) the STL sources as input, then you should set this
+# tag to YES in order to let doxygen match functions declarations and
+# definitions whose arguments contain STL classes (e.g. func(std::string);
+# versus func(std::string) {}). This also make the inheritance and collaboration
+# diagrams that involve STL classes more complete and accurate.
+# The default value is: NO.
+
+BUILTIN_STL_SUPPORT = NO
+
+# If you use Microsoft's C++/CLI language, you should set this option to YES to
+# enable parsing support.
+# The default value is: NO.
+
+CPP_CLI_SUPPORT = NO
+
+# Set the SIP_SUPPORT tag to YES if your project consists of sip (see:
+# http://www.riverbankcomputing.co.uk/software/sip/intro) sources only. Doxygen
+# will parse them like normal C++ but will assume all classes use public instead
+# of private inheritance when no explicit protection keyword is present.
+# The default value is: NO.
+
+SIP_SUPPORT = NO
+
+# For Microsoft's IDL there are propget and propput attributes to indicate
+# getter and setter methods for a property. Setting this option to YES will make
+# doxygen to replace the get and set methods by a property in the documentation.
+# This will only work if the methods are indeed getting or setting a simple
+# type. If this is not the case, or you want to show the methods anyway, you
+# should set this option to NO.
+# The default value is: YES.
+
+IDL_PROPERTY_SUPPORT = NO
+
+# If member grouping is used in the documentation and the DISTRIBUTE_GROUP_DOC
+# tag is set to YES, then doxygen will reuse the documentation of the first
+# member in the group (if any) for the other members of the group. By default
+# all members of a group must be documented explicitly.
+# The default value is: NO.
+
+DISTRIBUTE_GROUP_DOC = NO
+
+# Set the SUBGROUPING tag to YES to allow class member groups of the same type
+# (for instance a group of public functions) to be put as a subgroup of that
+# type (e.g. under the Public Functions section). Set it to NO to prevent
+# subgrouping. Alternatively, this can be done per class using the
+# \nosubgrouping command.
+# The default value is: YES.
+
+SUBGROUPING = YES
+
+# When the INLINE_GROUPED_CLASSES tag is set to YES, classes, structs and unions
+# are shown inside the group in which they are included (e.g. using \ingroup)
+# instead of on a separate page (for HTML and Man pages) or section (for LaTeX
+# and RTF).
+#
+# Note that this feature does not work in combination with
+# SEPARATE_MEMBER_PAGES.
+# The default value is: NO.
+
+INLINE_GROUPED_CLASSES = NO
+
+# When the INLINE_SIMPLE_STRUCTS tag is set to YES, structs, classes, and unions
+# with only public data fields or simple typedef fields will be shown inline in
+# the documentation of the scope in which they are defined (i.e. file,
+# namespace, or group documentation), provided this scope is documented. If set
+# to NO, structs, classes, and unions are shown on a separate page (for HTML and
+# Man pages) or section (for LaTeX and RTF).
+# The default value is: NO.
+
+INLINE_SIMPLE_STRUCTS = NO
+
+# When TYPEDEF_HIDES_STRUCT tag is enabled, a typedef of a struct, union, or
+# enum is documented as struct, union, or enum with the name of the typedef. So
+# typedef struct TypeS {} TypeT, will appear in the documentation as a struct
+# with name TypeT. When disabled the typedef will appear as a member of a file,
+# namespace, or class. And the struct will be named TypeS. This can typically be
+# useful for C code in case the coding convention dictates that all compound
+# types are typedef'ed and only the typedef is referenced, never the tag name.
+# The default value is: NO.
+
+TYPEDEF_HIDES_STRUCT = NO
+
+# The size of the symbol lookup cache can be set using LOOKUP_CACHE_SIZE. This
+# cache is used to resolve symbols given their name and scope. Since this can be
+# an expensive process and often the same symbol appears multiple times in the
+# code, doxygen keeps a cache of pre-resolved symbols. If the cache is too small
+# doxygen will become slower. If the cache is too large, memory is wasted. The
+# cache size is given by this formula: 2^(16+LOOKUP_CACHE_SIZE). The valid range
+# is 0..9, the default is 0, corresponding to a cache size of 2^16=65536
+# symbols. At the end of a run doxygen will report the cache usage and suggest
+# the optimal cache size from a speed point of view.
+# Minimum value: 0, maximum value: 9, default value: 0.
+
+LOOKUP_CACHE_SIZE = 0
+
+#---------------------------------------------------------------------------
+# Build related configuration options
+#---------------------------------------------------------------------------
+
+# If the EXTRACT_ALL tag is set to YES doxygen will assume all entities in
+# documentation are documented, even if no documentation was available. Private
+# class members and static file members will be hidden unless the
+# EXTRACT_PRIVATE respectively EXTRACT_STATIC tags are set to YES.
+# Note: This will also disable the warnings about undocumented members that are
+# normally produced when WARNINGS is set to YES.
+# The default value is: NO.
+
+EXTRACT_ALL = YES
+
+# If the EXTRACT_PRIVATE tag is set to YES all private members of a class will
+# be included in the documentation.
+# The default value is: NO.
+
+EXTRACT_PRIVATE = NO
+
+# If the EXTRACT_PACKAGE tag is set to YES all members with package or internal
+# scope will be included in the documentation.
+# The default value is: NO.
+
+EXTRACT_PACKAGE = NO
+
+# If the EXTRACT_STATIC tag is set to YES all static members of a file will be
+# included in the documentation.
+# The default value is: NO.
+
+EXTRACT_STATIC = NO
+
+# If the EXTRACT_LOCAL_CLASSES tag is set to YES classes (and structs) defined
+# locally in source files will be included in the documentation. If set to NO
+# only classes defined in header files are included. Does not have any effect
+# for Java sources.
+# The default value is: YES.
+
+EXTRACT_LOCAL_CLASSES = YES
+
+# This flag is only useful for Objective-C code. When set to YES local methods,
+# which are defined in the implementation section but not in the interface are
+# included in the documentation. If set to NO only methods in the interface are
+# included.
+# The default value is: NO.
+
+EXTRACT_LOCAL_METHODS = NO
+
+# If this flag is set to YES, the members of anonymous namespaces will be
+# extracted and appear in the documentation as a namespace called
+# 'anonymous_namespace{file}', where file will be replaced with the base name of
+# the file that contains the anonymous namespace. By default anonymous namespace
+# are hidden.
+# The default value is: NO.
+
+EXTRACT_ANON_NSPACES = NO
+
+# If the HIDE_UNDOC_MEMBERS tag is set to YES, doxygen will hide all
+# undocumented members inside documented classes or files. If set to NO these
+# members will be included in the various overviews, but no documentation
+# section is generated. This option has no effect if EXTRACT_ALL is enabled.
+# The default value is: NO.
+
+HIDE_UNDOC_MEMBERS = NO
+
+# If the HIDE_UNDOC_CLASSES tag is set to YES, doxygen will hide all
+# undocumented classes that are normally visible in the class hierarchy. If set
+# to NO these classes will be included in the various overviews. This option has
+# no effect if EXTRACT_ALL is enabled.
+# The default value is: NO.
+
+HIDE_UNDOC_CLASSES = NO
+
+# If the HIDE_FRIEND_COMPOUNDS tag is set to YES, doxygen will hide all friend
+# (class|struct|union) declarations. If set to NO these declarations will be
+# included in the documentation.
+# The default value is: NO.
+
+HIDE_FRIEND_COMPOUNDS = NO
+
+# If the HIDE_IN_BODY_DOCS tag is set to YES, doxygen will hide any
+# documentation blocks found inside the body of a function. If set to NO these
+# blocks will be appended to the function's detailed documentation block.
+# The default value is: NO.
+
+HIDE_IN_BODY_DOCS = NO
+
+# The INTERNAL_DOCS tag determines if documentation that is typed after a
+# \internal command is included. If the tag is set to NO then the documentation
+# will be excluded. Set it to YES to include the internal documentation.
+# The default value is: NO.
+
+INTERNAL_DOCS = NO
+
+# If the CASE_SENSE_NAMES tag is set to NO then doxygen will only generate file
+# names in lower-case letters. If set to YES upper-case letters are also
+# allowed. This is useful if you have classes or files whose names only differ
+# in case and if your file system supports case sensitive file names. Windows
+# and Mac users are advised to set this option to NO.
+# The default value is: system dependent.
+
+CASE_SENSE_NAMES = NO
+
+# If the HIDE_SCOPE_NAMES tag is set to NO then doxygen will show members with
+# their full class and namespace scopes in the documentation. If set to YES the
+# scope will be hidden.
+# The default value is: NO.
+
+HIDE_SCOPE_NAMES = NO
+
+# If the SHOW_INCLUDE_FILES tag is set to YES then doxygen will put a list of
+# the files that are included by a file in the documentation of that file.
+# The default value is: YES.
+
+SHOW_INCLUDE_FILES = YES
+
+# If the FORCE_LOCAL_INCLUDES tag is set to YES then doxygen will list include
+# files with double quotes in the documentation rather than with sharp brackets.
+# The default value is: NO.
+
+FORCE_LOCAL_INCLUDES = NO
+
+# If the INLINE_INFO tag is set to YES then a tag [inline] is inserted in the
+# documentation for inline members.
+# The default value is: YES.
+
+INLINE_INFO = YES
+
+# If the SORT_MEMBER_DOCS tag is set to YES then doxygen will sort the
+# (detailed) documentation of file and class members alphabetically by member
+# name. If set to NO the members will appear in declaration order.
+# The default value is: YES.
+
+SORT_MEMBER_DOCS = YES
+
+# If the SORT_BRIEF_DOCS tag is set to YES then doxygen will sort the brief
+# descriptions of file, namespace and class members alphabetically by member
+# name. If set to NO the members will appear in declaration order.
+# The default value is: NO.
+
+SORT_BRIEF_DOCS = NO
+
+# If the SORT_MEMBERS_CTORS_1ST tag is set to YES then doxygen will sort the
+# (brief and detailed) documentation of class members so that constructors and
+# destructors are listed first. If set to NO the constructors will appear in the
+# respective orders defined by SORT_BRIEF_DOCS and SORT_MEMBER_DOCS.
+# Note: If SORT_BRIEF_DOCS is set to NO this option is ignored for sorting brief
+# member documentation.
+# Note: If SORT_MEMBER_DOCS is set to NO this option is ignored for sorting
+# detailed member documentation.
+# The default value is: NO.
+
+SORT_MEMBERS_CTORS_1ST = NO
+
+# If the SORT_GROUP_NAMES tag is set to YES then doxygen will sort the hierarchy
+# of group names into alphabetical order. If set to NO the group names will
+# appear in their defined order.
+# The default value is: NO.
+
+SORT_GROUP_NAMES = NO
+
+# If the SORT_BY_SCOPE_NAME tag is set to YES, the class list will be sorted by
+# fully-qualified names, including namespaces. If set to NO, the class list will
+# be sorted only by class name, not including the namespace part.
+# Note: This option is not very useful if HIDE_SCOPE_NAMES is set to YES.
+# Note: This option applies only to the class list, not to the alphabetical
+# list.
+# The default value is: NO.
+
+SORT_BY_SCOPE_NAME = NO
+
+# If the STRICT_PROTO_MATCHING option is enabled and doxygen fails to do proper
+# type resolution of all parameters of a function it will reject a match between
+# the prototype and the implementation of a member function even if there is
+# only one candidate or it is obvious which candidate to choose by doing a
+# simple string match. By disabling STRICT_PROTO_MATCHING doxygen will still
+# accept a match between prototype and implementation in such cases.
+# The default value is: NO.
+
+STRICT_PROTO_MATCHING = NO
+
+# The GENERATE_TODOLIST tag can be used to enable ( YES) or disable ( NO) the
+# todo list. This list is created by putting \todo commands in the
+# documentation.
+# The default value is: YES.
+
+GENERATE_TODOLIST = NO
+
+# The GENERATE_TESTLIST tag can be used to enable ( YES) or disable ( NO) the
+# test list. This list is created by putting \test commands in the
+# documentation.
+# The default value is: YES.
+
+GENERATE_TESTLIST = NO
+
+# The GENERATE_BUGLIST tag can be used to enable ( YES) or disable ( NO) the bug
+# list. This list is created by putting \bug commands in the documentation.
+# The default value is: YES.
+
+GENERATE_BUGLIST = NO
+
+# The GENERATE_DEPRECATEDLIST tag can be used to enable ( YES) or disable ( NO)
+# the deprecated list. This list is created by putting \deprecated commands in
+# the documentation.
+# The default value is: YES.
+
+GENERATE_DEPRECATEDLIST= NO
+
+# The ENABLED_SECTIONS tag can be used to enable conditional documentation
+# sections, marked by \if <section_label> ... \endif and \cond <section_label>
+# ... \endcond blocks.
+
+ENABLED_SECTIONS =
+
+# The MAX_INITIALIZER_LINES tag determines the maximum number of lines that the
+# initial value of a variable or macro / define can have for it to appear in the
+# documentation. If the initializer consists of more lines than specified here
+# it will be hidden. Use a value of 0 to hide initializers completely. The
+# appearance of the value of individual variables and macros / defines can be
+# controlled using \showinitializer or \hideinitializer command in the
+# documentation regardless of this setting.
+# Minimum value: 0, maximum value: 10000, default value: 30.
+
+MAX_INITIALIZER_LINES = 30
+
+# Set the SHOW_USED_FILES tag to NO to disable the list of files generated at
+# the bottom of the documentation of classes and structs. If set to YES the list
+# will mention the files that were used to generate the documentation.
+# The default value is: YES.
+
+SHOW_USED_FILES = YES
+
+# Set the SHOW_FILES tag to NO to disable the generation of the Files page. This
+# will remove the Files entry from the Quick Index and from the Folder Tree View
+# (if specified).
+# The default value is: YES.
+
+SHOW_FILES = YES
+
+# Set the SHOW_NAMESPACES tag to NO to disable the generation of the Namespaces
+# page. This will remove the Namespaces entry from the Quick Index and from the
+# Folder Tree View (if specified).
+# The default value is: YES.
+
+SHOW_NAMESPACES = YES
+
+# The FILE_VERSION_FILTER tag can be used to specify a program or script that
+# doxygen should invoke to get the current version for each file (typically from
+# the version control system). Doxygen will invoke the program by executing (via
+# popen()) the command command input-file, where command is the value of the
+# FILE_VERSION_FILTER tag, and input-file is the name of an input file provided
+# by doxygen. Whatever the program writes to standard output is used as the file
+# version. For an example see the documentation.
+
+FILE_VERSION_FILTER =
+
+# The LAYOUT_FILE tag can be used to specify a layout file which will be parsed
+# by doxygen. The layout file controls the global structure of the generated
+# output files in an output format independent way. To create the layout file
+# that represents doxygen's defaults, run doxygen with the -l option. You can
+# optionally specify a file name after the option, if omitted DoxygenLayout.xml
+# will be used as the name of the layout file.
+#
+# Note that if you run doxygen from a directory containing a file called
+# DoxygenLayout.xml, doxygen will parse it automatically even if the LAYOUT_FILE
+# tag is left empty.
+
+LAYOUT_FILE =
+
+# The CITE_BIB_FILES tag can be used to specify one or more bib files containing
+# the reference definitions. This must be a list of .bib files. The .bib
+# extension is automatically appended if omitted. This requires the bibtex tool
+# to be installed. See also http://en.wikipedia.org/wiki/BibTeX for more info.
+# For LaTeX the style of the bibliography can be controlled using
+# LATEX_BIB_STYLE. To use this feature you need bibtex and perl available in the
+# search path. Do not use file names with spaces, bibtex cannot handle them. See
+# also \cite for info how to create references.
+
+CITE_BIB_FILES =
+
+#---------------------------------------------------------------------------
+# Configuration options related to warning and progress messages
+#---------------------------------------------------------------------------
+
+# The QUIET tag can be used to turn on/off the messages that are generated to
+# standard output by doxygen. If QUIET is set to YES this implies that the
+# messages are off.
+# The default value is: NO.
+
+QUIET = NO
+
+# The WARNINGS tag can be used to turn on/off the warning messages that are
+# generated to standard error ( stderr) by doxygen. If WARNINGS is set to YES
+# this implies that the warnings are on.
+#
+# Tip: Turn warnings on while writing the documentation.
+# The default value is: YES.
+
+WARNINGS = YES
+
+# If the WARN_IF_UNDOCUMENTED tag is set to YES, then doxygen will generate
+# warnings for undocumented members. If EXTRACT_ALL is set to YES then this flag
+# will automatically be disabled.
+# The default value is: YES.
+
+WARN_IF_UNDOCUMENTED = NO
+
+# If the WARN_IF_DOC_ERROR tag is set to YES, doxygen will generate warnings for
+# potential errors in the documentation, such as not documenting some parameters
+# in a documented function, or documenting parameters that don't exist or using
+# markup commands wrongly.
+# The default value is: YES.
+
+WARN_IF_DOC_ERROR = YES
+
+# This WARN_NO_PARAMDOC option can be enabled to get warnings for functions that
+# are documented, but have no documentation for their parameters or return
+# value. If set to NO doxygen will only warn about wrong or incomplete parameter
+# documentation, but not about the absence of documentation.
+# The default value is: NO.
+
+WARN_NO_PARAMDOC = NO
+
+# The WARN_FORMAT tag determines the format of the warning messages that doxygen
+# can produce. The string should contain the $file, $line, and $text tags, which
+# will be replaced by the file and line number from which the warning originated
+# and the warning text. Optionally the format may contain $version, which will
+# be replaced by the version of the file (if it could be obtained via
+# FILE_VERSION_FILTER)
+# The default value is: $file:$line: $text.
+
+WARN_FORMAT = "$file:$line: $text"
+
+# The WARN_LOGFILE tag can be used to specify a file to which warning and error
+# messages should be written. If left blank the output is written to standard
+# error (stderr).
+
+WARN_LOGFILE =
+
+#---------------------------------------------------------------------------
+# Configuration options related to the input files
+#---------------------------------------------------------------------------
+
+# The INPUT tag is used to specify the files and/or directories that contain
+# documented source files. You may enter file names like myfile.cpp or
+# directories like /usr/src/myproject. Separate the files or directories with
+# spaces.
+# Note: If this tag is empty the current directory is searched.
+
+INPUT = ../
+
+# This tag can be used to specify the character encoding of the source files
+# that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses
+# libiconv (or the iconv built into libc) for the transcoding. See the libiconv
+# documentation (see: http://www.gnu.org/software/libiconv) for the list of
+# possible encodings.
+# The default value is: UTF-8.
+
+INPUT_ENCODING = UTF-8
+
+# If the value of the INPUT tag contains directories, you can use the
+# FILE_PATTERNS tag to specify one or more wildcard patterns (like *.cpp and
+# *.h) to filter out the source-files in the directories. If left blank the
+# following patterns are tested:*.c, *.cc, *.cxx, *.cpp, *.c++, *.java, *.ii,
+# *.ixx, *.ipp, *.i++, *.inl, *.idl, *.ddl, *.odl, *.h, *.hh, *.hxx, *.hpp,
+# *.h++, *.cs, *.d, *.php, *.php4, *.php5, *.phtml, *.inc, *.m, *.markdown,
+# *.md, *.mm, *.dox, *.py, *.f90, *.f, *.for, *.tcl, *.vhd, *.vhdl, *.ucf,
+# *.qsf, *.as and *.js.
+
+FILE_PATTERNS = *.c \
+ *.cc \
+ *.cxx \
+ *.cpp \
+ *.c++ \
+ *.h \
+ *.inc \
+ *.f90 \
+ *.f \
+ *.C \
+ *.CC \
+ *.C++ \
+ *.H \
+ *.F90 \
+ *.F
+
+# The RECURSIVE tag can be used to specify whether or not subdirectories should
+# be searched for input files as well.
+# The default value is: NO.
+
+RECURSIVE = YES
+
+# The EXCLUDE tag can be used to specify files and/or directories that should be
+# excluded from the INPUT source files. This way you can easily exclude a
+# subdirectory from a directory tree whose root is specified with the INPUT tag.
+#
+# Note that relative paths are relative to the directory from which doxygen is
+# run.
+
+EXCLUDE = ../lapack \
+ ../blas \
+ ../AD \
+ ../tAD \
+ ../g_taf/mkTAF \
+ ../TAF \
+ ../tmp \
+ ../models \
+ ../tests \
+ ./ \
+ ../doc \
+ ../mach \
+ ../shemat_suite.bak \
+ ../.UNUSED \
+ ../inverse/borehole \
+ ../hdf5/integer32 \
+ ../hdf5/integer64 \
+ ../props/fluids \
+ ../simul/gs \
+ ../simul/sgsim \
+ ../simul/enkf \
+ ../simul/visim \
+ ../wrapper \
+ ../refine
+
+# The EXCLUDE_SYMLINKS tag can be used to select whether or not files or
+# directories that are symbolic links (a Unix file system feature) are excluded
+# from the input.
+# The default value is: NO.
+
+EXCLUDE_SYMLINKS = YES
+
+# If the value of the INPUT tag contains directories, you can use the
+# EXCLUDE_PATTERNS tag to specify one or more wildcard patterns to exclude
+# certain files from those directories.
+#
+# Note that the wildcards are matched against the file with absolute path, so to
+# exclude all test directories for example use the pattern */test/*
+
+EXCLUDE_PATTERNS = */AD/*
+
+# The EXCLUDE_SYMBOLS tag can be used to specify one or more symbol names
+# (namespaces, classes, functions, etc.) that should be excluded from the
+# output. The symbol name can be a fully qualified name, a word, or if the
+# wildcard * is used, a substring. Examples: ANamespace, AClass,
+# AClass::ANamespace, ANamespace::*Test
+#
+# Note that the wildcards are matched against the file with absolute path, so to
+# exclude all test directories use the pattern */test/*
+
+EXCLUDE_SYMBOLS =
+
+# The EXAMPLE_PATH tag can be used to specify one or more files or directories
+# that contain example code fragments that are included (see the \include
+# command).
+
+EXAMPLE_PATH =
+
+# If the value of the EXAMPLE_PATH tag contains directories, you can use the
+# EXAMPLE_PATTERNS tag to specify one or more wildcard pattern (like *.cpp and
+# *.h) to filter out the source-files in the directories. If left blank all
+# files are included.
+
+EXAMPLE_PATTERNS = *
+
+# If the EXAMPLE_RECURSIVE tag is set to YES then subdirectories will be
+# searched for input files to be used with the \include or \dontinclude commands
+# irrespective of the value of the RECURSIVE tag.
+# The default value is: NO.
+
+EXAMPLE_RECURSIVE = NO
+
+# The IMAGE_PATH tag can be used to specify one or more files or directories
+# that contain images that are to be included in the documentation (see the
+# \image command).
+
+IMAGE_PATH = ../doc/doc_image
+
+# The INPUT_FILTER tag can be used to specify a program that doxygen should
+# invoke to filter for each input file. Doxygen will invoke the filter program
+# by executing (via popen()) the command:
+#
+# <filter> <input-file>
+#
+# where <filter> is the value of the INPUT_FILTER tag, and <input-file> is the
+# name of an input file. Doxygen will then use the output that the filter
+# program writes to standard output. If FILTER_PATTERNS is specified, this tag
+# will be ignored.
+#
+# Note that the filter must not add or remove lines; it is applied before the
+# code is scanned, but not when the output code is generated. If lines are added
+# or removed, the anchors will not be placed correctly.
+
+INPUT_FILTER =
+
+# The FILTER_PATTERNS tag can be used to specify filters on a per file pattern
+# basis. Doxygen will compare the file name with each pattern and apply the
+# filter if there is a match. The filters are a list of the form: pattern=filter
+# (like *.cpp=my_cpp_filter). See INPUT_FILTER for further information on how
+# filters are used. If the FILTER_PATTERNS tag is empty or if none of the
+# patterns match the file name, INPUT_FILTER is applied.
+
+FILTER_PATTERNS =
+
+# If the FILTER_SOURCE_FILES tag is set to YES, the input filter (if set using
+# INPUT_FILTER ) will also be used to filter the input files that are used for
+# producing the source files to browse (i.e. when SOURCE_BROWSER is set to YES).
+# The default value is: NO.
+
+FILTER_SOURCE_FILES = NO
+
+# The FILTER_SOURCE_PATTERNS tag can be used to specify source filters per file
+# pattern. A pattern will override the setting for FILTER_PATTERN (if any) and
+# it is also possible to disable source filtering for a specific pattern using
+# *.ext= (so without naming a filter).
+# This tag requires that the tag FILTER_SOURCE_FILES is set to YES.
+
+FILTER_SOURCE_PATTERNS =
+
+# If the USE_MDFILE_AS_MAINPAGE tag refers to the name of a markdown file that
+# is part of the input, its contents will be placed on the main page
+# (index.html). This can be useful if you have a project on for instance GitHub
+# and want to reuse the introduction page also for the doxygen output.
+
+USE_MDFILE_AS_MAINPAGE =
+
+#---------------------------------------------------------------------------
+# Configuration options related to source browsing
+#---------------------------------------------------------------------------
+
+# If the SOURCE_BROWSER tag is set to YES then a list of source files will be
+# generated. Documented entities will be cross-referenced with these sources.
+#
+# Note: To get rid of all source code in the generated output, make sure that
+# also VERBATIM_HEADERS is set to NO.
+# The default value is: NO.
+
+SOURCE_BROWSER = YES
+
+# Setting the INLINE_SOURCES tag to YES will include the body of functions,
+# classes and enums directly into the documentation.
+# The default value is: NO.
+
+INLINE_SOURCES = YES
+
+# Setting the STRIP_CODE_COMMENTS tag to YES will instruct doxygen to hide any
+# special comment blocks from generated source code fragments. Normal C, C++ and
+# Fortran comments will always remain visible.
+# The default value is: YES.
+
+STRIP_CODE_COMMENTS = YES
+
+# If the REFERENCED_BY_RELATION tag is set to YES then for each documented
+# function all documented functions referencing it will be listed.
+# The default value is: NO.
+
+REFERENCED_BY_RELATION = NO
+
+# If the REFERENCES_RELATION tag is set to YES then for each documented function
+# all documented entities called/used by that function will be listed.
+# The default value is: NO.
+
+REFERENCES_RELATION = NO
+
+# If the REFERENCES_LINK_SOURCE tag is set to YES and SOURCE_BROWSER tag is set
+# to YES, then the hyperlinks from functions in REFERENCES_RELATION and
+# REFERENCED_BY_RELATION lists will link to the source code. Otherwise they will
+# link to the documentation.
+# The default value is: YES.
+
+REFERENCES_LINK_SOURCE = YES
+
+# If SOURCE_TOOLTIPS is enabled (the default) then hovering a hyperlink in the
+# source code will show a tooltip with additional information such as prototype,
+# brief description and links to the definition and documentation. Since this
+# will make the HTML file larger and loading of large files a bit slower, you
+# can opt to disable this feature.
+# The default value is: YES.
+# This tag requires that the tag SOURCE_BROWSER is set to YES.
+
+SOURCE_TOOLTIPS = YES
+
+# If the USE_HTAGS tag is set to YES then the references to source code will
+# point to the HTML generated by the htags(1) tool instead of doxygen built-in
+# source browser. The htags tool is part of GNU's global source tagging system
+# (see http://www.gnu.org/software/global/global.html). You will need version
+# 4.8.6 or higher.
+#
+# To use it do the following:
+# - Install the latest version of global
+# - Enable SOURCE_BROWSER and USE_HTAGS in the config file
+# - Make sure the INPUT points to the root of the source tree
+# - Run doxygen as normal
+#
+# Doxygen will invoke htags (and that will in turn invoke gtags), so these
+# tools must be available from the command line (i.e. in the search path).
+#
+# The result: instead of the source browser generated by doxygen, the links to
+# source code will now point to the output of htags.
+# The default value is: NO.
+# This tag requires that the tag SOURCE_BROWSER is set to YES.
+
+USE_HTAGS = NO
+
+# If the VERBATIM_HEADERS tag is set the YES then doxygen will generate a
+# verbatim copy of the header file for each class for which an include is
+# specified. Set to NO to disable this.
+# See also: Section \class.
+# The default value is: YES.
+
+VERBATIM_HEADERS = YES
+
+#---------------------------------------------------------------------------
+# Configuration options related to the alphabetical class index
+#---------------------------------------------------------------------------
+
+# If the ALPHABETICAL_INDEX tag is set to YES, an alphabetical index of all
+# compounds will be generated. Enable this if the project contains a lot of
+# classes, structs, unions or interfaces.
+# The default value is: YES.
+
+ALPHABETICAL_INDEX = NO
+
+# The COLS_IN_ALPHA_INDEX tag can be used to specify the number of columns in
+# which the alphabetical index list will be split.
+# Minimum value: 1, maximum value: 20, default value: 5.
+# This tag requires that the tag ALPHABETICAL_INDEX is set to YES.
+
+COLS_IN_ALPHA_INDEX = 5
+
+# In case all classes in a project start with a common prefix, all classes will
+# be put under the same header in the alphabetical index. The IGNORE_PREFIX tag
+# can be used to specify a prefix (or a list of prefixes) that should be ignored
+# while generating the index headers.
+# This tag requires that the tag ALPHABETICAL_INDEX is set to YES.
+
+IGNORE_PREFIX =
+
+#---------------------------------------------------------------------------
+# Configuration options related to the HTML output
+#---------------------------------------------------------------------------
+
+# If the GENERATE_HTML tag is set to YES doxygen will generate HTML output
+# The default value is: YES.
+
+GENERATE_HTML = YES
+
+# The HTML_OUTPUT tag is used to specify where the HTML docs will be put. If a
+# relative path is entered the value of OUTPUT_DIRECTORY will be put in front of
+# it.
+# The default directory is: html.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+HTML_OUTPUT = html
+
+# The HTML_FILE_EXTENSION tag can be used to specify the file extension for each
+# generated HTML page (for example: .htm, .php, .asp).
+# The default value is: .html.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+HTML_FILE_EXTENSION = .html
+
+# The HTML_HEADER tag can be used to specify a user-defined HTML header file for
+# each generated HTML page. If the tag is left blank doxygen will generate a
+# standard header.
+#
+# To get valid HTML the header file that includes any scripts and style sheets
+# that doxygen needs, which is dependent on the configuration options used (e.g.
+# the setting GENERATE_TREEVIEW). It is highly recommended to start with a
+# default header using
+# doxygen -w html new_header.html new_footer.html new_stylesheet.css
+# YourConfigFile
+# and then modify the file new_header.html. See also section "Doxygen usage"
+# for information on how to generate the default header that doxygen normally
+# uses.
+# Note: The header is subject to change so you typically have to regenerate the
+# default header when upgrading to a newer version of doxygen. For a description
+# of the possible markers and block names see the documentation.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+HTML_HEADER =
+
+# The HTML_FOOTER tag can be used to specify a user-defined HTML footer for each
+# generated HTML page. If the tag is left blank doxygen will generate a standard
+# footer. See HTML_HEADER for more information on how to generate a default
+# footer and what special commands can be used inside the footer. See also
+# section "Doxygen usage" for information on how to generate the default footer
+# that doxygen normally uses.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+HTML_FOOTER =
+
+# The HTML_STYLESHEET tag can be used to specify a user-defined cascading style
+# sheet that is used by each HTML page. It can be used to fine-tune the look of
+# the HTML output. If left blank doxygen will generate a default style sheet.
+# See also section "Doxygen usage" for information on how to generate the style
+# sheet that doxygen normally uses.
+# Note: It is recommended to use HTML_EXTRA_STYLESHEET instead of this tag, as
+# it is more robust and this tag (HTML_STYLESHEET) will in the future become
+# obsolete.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+HTML_STYLESHEET =
+
+# The HTML_EXTRA_STYLESHEET tag can be used to specify an additional user-
+# defined cascading style sheet that is included after the standard style sheets
+# created by doxygen. Using this option one can overrule certain style aspects.
+# This is preferred over using HTML_STYLESHEET since it does not replace the
+# standard style sheet and is therefor more robust against future updates.
+# Doxygen will copy the style sheet file to the output directory. For an example
+# see the documentation.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+HTML_EXTRA_STYLESHEET =
+
+# The HTML_EXTRA_FILES tag can be used to specify one or more extra images or
+# other source files which should be copied to the HTML output directory. Note
+# that these files will be copied to the base HTML output directory. Use the
+# $relpath^ marker in the HTML_HEADER and/or HTML_FOOTER files to load these
+# files. In the HTML_STYLESHEET file, use the file name only. Also note that the
+# files will be copied as-is; there are no commands or markers available.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+HTML_EXTRA_FILES =
+
+# The HTML_COLORSTYLE_HUE tag controls the color of the HTML output. Doxygen
+# will adjust the colors in the stylesheet and background images according to
+# this color. Hue is specified as an angle on a colorwheel, see
+# http://en.wikipedia.org/wiki/Hue for more information. For instance the value
+# 0 represents red, 60 is yellow, 120 is green, 180 is cyan, 240 is blue, 300
+# purple, and 360 is red again.
+# Minimum value: 0, maximum value: 359, default value: 220.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+HTML_COLORSTYLE_HUE = 220
+
+# The HTML_COLORSTYLE_SAT tag controls the purity (or saturation) of the colors
+# in the HTML output. For a value of 0 the output will use grayscales only. A
+# value of 255 will produce the most vivid colors.
+# Minimum value: 0, maximum value: 255, default value: 100.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+HTML_COLORSTYLE_SAT = 100
+
+# The HTML_COLORSTYLE_GAMMA tag controls the gamma correction applied to the
+# luminance component of the colors in the HTML output. Values below 100
+# gradually make the output lighter, whereas values above 100 make the output
+# darker. The value divided by 100 is the actual gamma applied, so 80 represents
+# a gamma of 0.8, The value 220 represents a gamma of 2.2, and 100 does not
+# change the gamma.
+# Minimum value: 40, maximum value: 240, default value: 80.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+HTML_COLORSTYLE_GAMMA = 80
+
+# If the HTML_TIMESTAMP tag is set to YES then the footer of each generated HTML
+# page will contain the date and time when the page was generated. Setting this
+# to NO can help when comparing the output of multiple runs.
+# The default value is: YES.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+HTML_TIMESTAMP = NO
+
+# If the HTML_DYNAMIC_SECTIONS tag is set to YES then the generated HTML
+# documentation will contain sections that can be hidden and shown after the
+# page has loaded.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+HTML_DYNAMIC_SECTIONS = NO
+
+# With HTML_INDEX_NUM_ENTRIES one can control the preferred number of entries
+# shown in the various tree structured indices initially; the user can expand
+# and collapse entries dynamically later on. Doxygen will expand the tree to
+# such a level that at most the specified number of entries are visible (unless
+# a fully collapsed tree already exceeds this amount). So setting the number of
+# entries 1 will produce a full collapsed tree by default. 0 is a special value
+# representing an infinite number of entries and will result in a full expanded
+# tree by default.
+# Minimum value: 0, maximum value: 9999, default value: 100.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+HTML_INDEX_NUM_ENTRIES = 100
+
+# If the GENERATE_DOCSET tag is set to YES, additional index files will be
+# generated that can be used as input for Apple's Xcode 3 integrated development
+# environment (see: http://developer.apple.com/tools/xcode/), introduced with
+# OSX 10.5 (Leopard). To create a documentation set, doxygen will generate a
+# Makefile in the HTML output directory. Running make will produce the docset in
+# that directory and running make install will install the docset in
+# ~/Library/Developer/Shared/Documentation/DocSets so that Xcode will find it at
+# startup. See http://developer.apple.com/tools/creatingdocsetswithdoxygen.html
+# for more information.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+GENERATE_DOCSET = NO
+
+# This tag determines the name of the docset feed. A documentation feed provides
+# an umbrella under which multiple documentation sets from a single provider
+# (such as a company or product suite) can be grouped.
+# The default value is: Doxygen generated docs.
+# This tag requires that the tag GENERATE_DOCSET is set to YES.
+
+DOCSET_FEEDNAME = "Doxygen generated docs"
+
+# This tag specifies a string that should uniquely identify the documentation
+# set bundle. This should be a reverse domain-name style string, e.g.
+# com.mycompany.MyDocSet. Doxygen will append .docset to the name.
+# The default value is: org.doxygen.Project.
+# This tag requires that the tag GENERATE_DOCSET is set to YES.
+
+DOCSET_BUNDLE_ID = org.doxygen.Project
+
+# The DOCSET_PUBLISHER_ID tag specifies a string that should uniquely identify
+# the documentation publisher. This should be a reverse domain-name style
+# string, e.g. com.mycompany.MyDocSet.documentation.
+# The default value is: org.doxygen.Publisher.
+# This tag requires that the tag GENERATE_DOCSET is set to YES.
+
+DOCSET_PUBLISHER_ID = org.doxygen.Publisher
+
+# The DOCSET_PUBLISHER_NAME tag identifies the documentation publisher.
+# The default value is: Publisher.
+# This tag requires that the tag GENERATE_DOCSET is set to YES.
+
+DOCSET_PUBLISHER_NAME = Publisher
+
+# If the GENERATE_HTMLHELP tag is set to YES then doxygen generates three
+# additional HTML index files: index.hhp, index.hhc, and index.hhk. The
+# index.hhp is a project file that can be read by Microsoft's HTML Help Workshop
+# (see: http://www.microsoft.com/en-us/download/details.aspx?id=21138) on
+# Windows.
+#
+# The HTML Help Workshop contains a compiler that can convert all HTML output
+# generated by doxygen into a single compiled HTML file (.chm). Compiled HTML
+# files are now used as the Windows 98 help format, and will replace the old
+# Windows help format (.hlp) on all Windows platforms in the future. Compressed
+# HTML files also contain an index, a table of contents, and you can search for
+# words in the documentation. The HTML workshop also contains a viewer for
+# compressed HTML files.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+GENERATE_HTMLHELP = NO
+
+# The CHM_FILE tag can be used to specify the file name of the resulting .chm
+# file. You can add a path in front of the file if the result should not be
+# written to the html output directory.
+# This tag requires that the tag GENERATE_HTMLHELP is set to YES.
+
+CHM_FILE =
+
+# The HHC_LOCATION tag can be used to specify the location (absolute path
+# including file name) of the HTML help compiler ( hhc.exe). If non-empty
+# doxygen will try to run the HTML help compiler on the generated index.hhp.
+# The file has to be specified with full path.
+# This tag requires that the tag GENERATE_HTMLHELP is set to YES.
+
+HHC_LOCATION =
+
+# The GENERATE_CHI flag controls if a separate .chi index file is generated (
+# YES) or that it should be included in the master .chm file ( NO).
+# The default value is: NO.
+# This tag requires that the tag GENERATE_HTMLHELP is set to YES.
+
+GENERATE_CHI = NO
+
+# The CHM_INDEX_ENCODING is used to encode HtmlHelp index ( hhk), content ( hhc)
+# and project file content.
+# This tag requires that the tag GENERATE_HTMLHELP is set to YES.
+
+CHM_INDEX_ENCODING =
+
+# The BINARY_TOC flag controls whether a binary table of contents is generated (
+# YES) or a normal table of contents ( NO) in the .chm file.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_HTMLHELP is set to YES.
+
+BINARY_TOC = NO
+
+# The TOC_EXPAND flag can be set to YES to add extra items for group members to
+# the table of contents of the HTML help documentation and to the tree view.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_HTMLHELP is set to YES.
+
+TOC_EXPAND = NO
+
+# If the GENERATE_QHP tag is set to YES and both QHP_NAMESPACE and
+# QHP_VIRTUAL_FOLDER are set, an additional index file will be generated that
+# can be used as input for Qt's qhelpgenerator to generate a Qt Compressed Help
+# (.qch) of the generated HTML documentation.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+GENERATE_QHP = NO
+
+# If the QHG_LOCATION tag is specified, the QCH_FILE tag can be used to specify
+# the file name of the resulting .qch file. The path specified is relative to
+# the HTML output folder.
+# This tag requires that the tag GENERATE_QHP is set to YES.
+
+QCH_FILE =
+
+# The QHP_NAMESPACE tag specifies the namespace to use when generating Qt Help
+# Project output. For more information please see Qt Help Project / Namespace
+# (see: http://qt-project.org/doc/qt-4.8/qthelpproject.html#namespace).
+# The default value is: org.doxygen.Project.
+# This tag requires that the tag GENERATE_QHP is set to YES.
+
+QHP_NAMESPACE = org.doxygen.Project
+
+# The QHP_VIRTUAL_FOLDER tag specifies the namespace to use when generating Qt
+# Help Project output. For more information please see Qt Help Project / Virtual
+# Folders (see: http://qt-project.org/doc/qt-4.8/qthelpproject.html#virtual-
+# folders).
+# The default value is: doc.
+# This tag requires that the tag GENERATE_QHP is set to YES.
+
+QHP_VIRTUAL_FOLDER = doc
+
+# If the QHP_CUST_FILTER_NAME tag is set, it specifies the name of a custom
+# filter to add. For more information please see Qt Help Project / Custom
+# Filters (see: http://qt-project.org/doc/qt-4.8/qthelpproject.html#custom-
+# filters).
+# This tag requires that the tag GENERATE_QHP is set to YES.
+
+QHP_CUST_FILTER_NAME =
+
+# The QHP_CUST_FILTER_ATTRS tag specifies the list of the attributes of the
+# custom filter to add. For more information please see Qt Help Project / Custom
+# Filters (see: http://qt-project.org/doc/qt-4.8/qthelpproject.html#custom-
+# filters).
+# This tag requires that the tag GENERATE_QHP is set to YES.
+
+QHP_CUST_FILTER_ATTRS =
+
+# The QHP_SECT_FILTER_ATTRS tag specifies the list of the attributes this
+# project's filter section matches. Qt Help Project / Filter Attributes (see:
+# http://qt-project.org/doc/qt-4.8/qthelpproject.html#filter-attributes).
+# This tag requires that the tag GENERATE_QHP is set to YES.
+
+QHP_SECT_FILTER_ATTRS =
+
+# The QHG_LOCATION tag can be used to specify the location of Qt's
+# qhelpgenerator. If non-empty doxygen will try to run qhelpgenerator on the
+# generated .qhp file.
+# This tag requires that the tag GENERATE_QHP is set to YES.
+
+QHG_LOCATION =
+
+# If the GENERATE_ECLIPSEHELP tag is set to YES, additional index files will be
+# generated, together with the HTML files, they form an Eclipse help plugin. To
+# install this plugin and make it available under the help contents menu in
+# Eclipse, the contents of the directory containing the HTML and XML files needs
+# to be copied into the plugins directory of eclipse. The name of the directory
+# within the plugins directory should be the same as the ECLIPSE_DOC_ID value.
+# After copying Eclipse needs to be restarted before the help appears.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+GENERATE_ECLIPSEHELP = NO
+
+# A unique identifier for the Eclipse help plugin. When installing the plugin
+# the directory name containing the HTML and XML files should also have this
+# name. Each documentation set should have its own identifier.
+# The default value is: org.doxygen.Project.
+# This tag requires that the tag GENERATE_ECLIPSEHELP is set to YES.
+
+ECLIPSE_DOC_ID = org.doxygen.Project
+
+# If you want full control over the layout of the generated HTML pages it might
+# be necessary to disable the index and replace it with your own. The
+# DISABLE_INDEX tag can be used to turn on/off the condensed index (tabs) at top
+# of each HTML page. A value of NO enables the index and the value YES disables
+# it. Since the tabs in the index contain the same information as the navigation
+# tree, you can set this option to YES if you also set GENERATE_TREEVIEW to YES.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+DISABLE_INDEX = NO
+
+# The GENERATE_TREEVIEW tag is used to specify whether a tree-like index
+# structure should be generated to display hierarchical information. If the tag
+# value is set to YES, a side panel will be generated containing a tree-like
+# index structure (just like the one that is generated for HTML Help). For this
+# to work a browser that supports JavaScript, DHTML, CSS and frames is required
+# (i.e. any modern browser). Windows users are probably better off using the
+# HTML help feature. Via custom stylesheets (see HTML_EXTRA_STYLESHEET) one can
+# further fine-tune the look of the index. As an example, the default style
+# sheet generated by doxygen has an example that shows how to put an image at
+# the root of the tree instead of the PROJECT_NAME. Since the tree basically has
+# the same information as the tab index, you could consider setting
+# DISABLE_INDEX to YES when enabling this option.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+GENERATE_TREEVIEW = NONE
+
+# The ENUM_VALUES_PER_LINE tag can be used to set the number of enum values that
+# doxygen will group on one line in the generated HTML documentation.
+#
+# Note that a value of 0 will completely suppress the enum values from appearing
+# in the overview section.
+# Minimum value: 0, maximum value: 20, default value: 4.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+ENUM_VALUES_PER_LINE = 4
+
+# If the treeview is enabled (see GENERATE_TREEVIEW) then this tag can be used
+# to set the initial width (in pixels) of the frame in which the tree is shown.
+# Minimum value: 0, maximum value: 1500, default value: 250.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+TREEVIEW_WIDTH = 250
+
+# When the EXT_LINKS_IN_WINDOW option is set to YES doxygen will open links to
+# external symbols imported via tag files in a separate window.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+EXT_LINKS_IN_WINDOW = NO
+
+# Use this tag to change the font size of LaTeX formulas included as images in
+# the HTML documentation. When you change the font size after a successful
+# doxygen run you need to manually remove any form_*.png images from the HTML
+# output directory to force them to be regenerated.
+# Minimum value: 8, maximum value: 50, default value: 10.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+FORMULA_FONTSIZE = 10
+
+# Use the FORMULA_TRANPARENT tag to determine whether or not the images
+# generated for formulas are transparent PNGs. Transparent PNGs are not
+# supported properly for IE 6.0, but are supported on all modern browsers.
+#
+# Note that when changing this option you need to delete any form_*.png files in
+# the HTML output directory before the changes have effect.
+# The default value is: YES.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+FORMULA_TRANSPARENT = YES
+
+# Enable the USE_MATHJAX option to render LaTeX formulas using MathJax (see
+# http://www.mathjax.org) which uses client side Javascript for the rendering
+# instead of using prerendered bitmaps. Use this if you do not have LaTeX
+# installed or if you want to formulas look prettier in the HTML output. When
+# enabled you may also need to install MathJax separately and configure the path
+# to it using the MATHJAX_RELPATH option.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+USE_MATHJAX = NO
+
+# When MathJax is enabled you can set the default output format to be used for
+# the MathJax output. See the MathJax site (see:
+# http://docs.mathjax.org/en/latest/output.html) for more details.
+# Possible values are: HTML-CSS (which is slower, but has the best
+# compatibility), NativeMML (i.e. MathML) and SVG.
+# The default value is: HTML-CSS.
+# This tag requires that the tag USE_MATHJAX is set to YES.
+
+MATHJAX_FORMAT = HTML-CSS
+
+# When MathJax is enabled you need to specify the location relative to the HTML
+# output directory using the MATHJAX_RELPATH option. The destination directory
+# should contain the MathJax.js script. For instance, if the mathjax directory
+# is located at the same level as the HTML output directory, then
+# MATHJAX_RELPATH should be ../mathjax. The default value points to the MathJax
+# Content Delivery Network so you can quickly see the result without installing
+# MathJax. However, it is strongly recommended to install a local copy of
+# MathJax from http://www.mathjax.org before deployment.
+# The default value is: http://cdn.mathjax.org/mathjax/latest.
+# This tag requires that the tag USE_MATHJAX is set to YES.
+
+MATHJAX_RELPATH = http://cdn.mathjax.org/mathjax/latest
+
+# The MATHJAX_EXTENSIONS tag can be used to specify one or more MathJax
+# extension names that should be enabled during MathJax rendering. For example
+# MATHJAX_EXTENSIONS = TeX/AMSmath TeX/AMSsymbols
+# This tag requires that the tag USE_MATHJAX is set to YES.
+
+MATHJAX_EXTENSIONS =
+
+# The MATHJAX_CODEFILE tag can be used to specify a file with javascript pieces
+# of code that will be used on startup of the MathJax code. See the MathJax site
+# (see: http://docs.mathjax.org/en/latest/output.html) for more details. For an
+# example see the documentation.
+# This tag requires that the tag USE_MATHJAX is set to YES.
+
+MATHJAX_CODEFILE =
+
+# When the SEARCHENGINE tag is enabled doxygen will generate a search box for
+# the HTML output. The underlying search engine uses javascript and DHTML and
+# should work on any modern browser. Note that when using HTML help
+# (GENERATE_HTMLHELP), Qt help (GENERATE_QHP), or docsets (GENERATE_DOCSET)
+# there is already a search function so this one should typically be disabled.
+# For large projects the javascript based search engine can be slow, then
+# enabling SERVER_BASED_SEARCH may provide a better solution. It is possible to
+# search using the keyboard; to jump to the search box use <access key> + S
+# (what the <access key> is depends on the OS and browser, but it is typically
+# <CTRL>, <ALT>/<option>, or both). Inside the search box use the <cursor down
+# key> to jump into the search results window, the results can be navigated
+# using the <cursor keys>. Press <Enter> to select an item or <escape> to cancel
+# the search. The filter options can be selected when the cursor is inside the
+# search box by pressing <Shift>+<cursor down>. Also here use the <cursor keys>
+# to select a filter and <Enter> or <escape> to activate or cancel the filter
+# option.
+# The default value is: YES.
+# This tag requires that the tag GENERATE_HTML is set to YES.
+
+SEARCHENGINE = YES
+
+# When the SERVER_BASED_SEARCH tag is enabled the search engine will be
+# implemented using a web server instead of a web client using Javascript. There
+# are two flavours of web server based searching depending on the
+# EXTERNAL_SEARCH setting. When disabled, doxygen will generate a PHP script for
+# searching and an index file used by the script. When EXTERNAL_SEARCH is
+# enabled the indexing and searching needs to be provided by external tools. See
+# the section "External Indexing and Searching" for details.
+# The default value is: NO.
+# This tag requires that the tag SEARCHENGINE is set to YES.
+
+SERVER_BASED_SEARCH = NO
+
+# When EXTERNAL_SEARCH tag is enabled doxygen will no longer generate the PHP
+# script for searching. Instead the search results are written to an XML file
+# which needs to be processed by an external indexer. Doxygen will invoke an
+# external search engine pointed to by the SEARCHENGINE_URL option to obtain the
+# search results.
+#
+# Doxygen ships with an example indexer ( doxyindexer) and search engine
+# (doxysearch.cgi) which are based on the open source search engine library
+# Xapian (see: http://xapian.org/).
+#
+# See the section "External Indexing and Searching" for details.
+# The default value is: NO.
+# This tag requires that the tag SEARCHENGINE is set to YES.
+
+EXTERNAL_SEARCH = NO
+
+# The SEARCHENGINE_URL should point to a search engine hosted by a web server
+# which will return the search results when EXTERNAL_SEARCH is enabled.
+#
+# Doxygen ships with an example indexer ( doxyindexer) and search engine
+# (doxysearch.cgi) which are based on the open source search engine library
+# Xapian (see: http://xapian.org/). See the section "External Indexing and
+# Searching" for details.
+# This tag requires that the tag SEARCHENGINE is set to YES.
+
+SEARCHENGINE_URL =
+
+# When SERVER_BASED_SEARCH and EXTERNAL_SEARCH are both enabled the unindexed
+# search data is written to a file for indexing by an external tool. With the
+# SEARCHDATA_FILE tag the name of this file can be specified.
+# The default file is: searchdata.xml.
+# This tag requires that the tag SEARCHENGINE is set to YES.
+
+SEARCHDATA_FILE = searchdata.xml
+
+# When SERVER_BASED_SEARCH and EXTERNAL_SEARCH are both enabled the
+# EXTERNAL_SEARCH_ID tag can be used as an identifier for the project. This is
+# useful in combination with EXTRA_SEARCH_MAPPINGS to search through multiple
+# projects and redirect the results back to the right project.
+# This tag requires that the tag SEARCHENGINE is set to YES.
+
+EXTERNAL_SEARCH_ID =
+
+# The EXTRA_SEARCH_MAPPINGS tag can be used to enable searching through doxygen
+# projects other than the one defined by this configuration file, but that are
+# all added to the same external search index. Each project needs to have a
+# unique id set via EXTERNAL_SEARCH_ID. The search mapping then maps the id of
+# to a relative location where the documentation can be found. The format is:
+# EXTRA_SEARCH_MAPPINGS = tagname1=loc1 tagname2=loc2 ...
+# This tag requires that the tag SEARCHENGINE is set to YES.
+
+EXTRA_SEARCH_MAPPINGS =
+
+#---------------------------------------------------------------------------
+# Configuration options related to the LaTeX output
+#---------------------------------------------------------------------------
+
+# If the GENERATE_LATEX tag is set to YES doxygen will generate LaTeX output.
+# The default value is: YES.
+
+GENERATE_LATEX = YES
+
+# The LATEX_OUTPUT tag is used to specify where the LaTeX docs will be put. If a
+# relative path is entered the value of OUTPUT_DIRECTORY will be put in front of
+# it.
+# The default directory is: latex.
+# This tag requires that the tag GENERATE_LATEX is set to YES.
+
+LATEX_OUTPUT = latex
+
+# The LATEX_CMD_NAME tag can be used to specify the LaTeX command name to be
+# invoked.
+#
+# Note that when enabling USE_PDFLATEX this option is only used for generating
+# bitmaps for formulas in the HTML output, but not in the Makefile that is
+# written to the output directory.
+# The default file is: latex.
+# This tag requires that the tag GENERATE_LATEX is set to YES.
+
+LATEX_CMD_NAME = latex
+
+# The MAKEINDEX_CMD_NAME tag can be used to specify the command name to generate
+# index for LaTeX.
+# The default file is: makeindex.
+# This tag requires that the tag GENERATE_LATEX is set to YES.
+
+MAKEINDEX_CMD_NAME = makeindex
+
+# If the COMPACT_LATEX tag is set to YES doxygen generates more compact LaTeX
+# documents. This may be useful for small projects and may help to save some
+# trees in general.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_LATEX is set to YES.
+
+COMPACT_LATEX = NO
+
+# The PAPER_TYPE tag can be used to set the paper type that is used by the
+# printer.
+# Possible values are: a4 (210 x 297 mm), letter (8.5 x 11 inches), legal (8.5 x
+# 14 inches) and executive (7.25 x 10.5 inches).
+# The default value is: a4.
+# This tag requires that the tag GENERATE_LATEX is set to YES.
+
+PAPER_TYPE = a4wide
+
+# The EXTRA_PACKAGES tag can be used to specify one or more LaTeX package names
+# that should be included in the LaTeX output. To get the times font for
+# instance you can specify
+# EXTRA_PACKAGES=times
+# If left blank no extra packages will be included.
+# This tag requires that the tag GENERATE_LATEX is set to YES.
+
+EXTRA_PACKAGES =
+
+# The LATEX_HEADER tag can be used to specify a personal LaTeX header for the
+# generated LaTeX document. The header should contain everything until the first
+# chapter. If it is left blank doxygen will generate a standard header. See
+# section "Doxygen usage" for information on how to let doxygen write the
+# default header to a separate file.
+#
+# Note: Only use a user-defined header if you know what you are doing! The
+# following commands have a special meaning inside the header: $title,
+# $datetime, $date, $doxygenversion, $projectname, $projectnumber. Doxygen will
+# replace them by respectively the title of the page, the current date and time,
+# only the current date, the version number of doxygen, the project name (see
+# PROJECT_NAME), or the project number (see PROJECT_NUMBER).
+# This tag requires that the tag GENERATE_LATEX is set to YES.
+
+LATEX_HEADER =
+
+# The LATEX_FOOTER tag can be used to specify a personal LaTeX footer for the
+# generated LaTeX document. The footer should contain everything after the last
+# chapter. If it is left blank doxygen will generate a standard footer.
+#
+# Note: Only use a user-defined footer if you know what you are doing!
+# This tag requires that the tag GENERATE_LATEX is set to YES.
+
+LATEX_FOOTER =
+
+# The LATEX_EXTRA_FILES tag can be used to specify one or more extra images or
+# other source files which should be copied to the LATEX_OUTPUT output
+# directory. Note that the files will be copied as-is; there are no commands or
+# markers available.
+# This tag requires that the tag GENERATE_LATEX is set to YES.
+
+LATEX_EXTRA_FILES =
+
+# If the PDF_HYPERLINKS tag is set to YES, the LaTeX that is generated is
+# prepared for conversion to PDF (using ps2pdf or pdflatex). The PDF file will
+# contain links (just like the HTML output) instead of page references. This
+# makes the output suitable for online browsing using a PDF viewer.
+# The default value is: YES.
+# This tag requires that the tag GENERATE_LATEX is set to YES.
+
+PDF_HYPERLINKS = YES
+
+# If the LATEX_PDFLATEX tag is set to YES, doxygen will use pdflatex to generate
+# the PDF file directly from the LaTeX files. Set this option to YES to get a
+# higher quality PDF documentation.
+# The default value is: YES.
+# This tag requires that the tag GENERATE_LATEX is set to YES.
+
+USE_PDFLATEX = YES
+
+# If the LATEX_BATCHMODE tag is set to YES, doxygen will add the \batchmode
+# command to the generated LaTeX files. This will instruct LaTeX to keep running
+# if errors occur, instead of asking the user for help. This option is also used
+# when generating formulas in HTML.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_LATEX is set to YES.
+
+LATEX_BATCHMODE = NO
+
+# If the LATEX_HIDE_INDICES tag is set to YES then doxygen will not include the
+# index chapters (such as File Index, Compound Index, etc.) in the output.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_LATEX is set to YES.
+
+LATEX_HIDE_INDICES = NO
+
+# If the LATEX_SOURCE_CODE tag is set to YES then doxygen will include source
+# code with syntax highlighting in the LaTeX output.
+#
+# Note that which sources are shown also depends on other settings such as
+# SOURCE_BROWSER.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_LATEX is set to YES.
+
+LATEX_SOURCE_CODE = NO
+
+# The LATEX_BIB_STYLE tag can be used to specify the style to use for the
+# bibliography, e.g. plainnat, or ieeetr. See
+# http://en.wikipedia.org/wiki/BibTeX and \cite for more info.
+# The default value is: plain.
+# This tag requires that the tag GENERATE_LATEX is set to YES.
+
+LATEX_BIB_STYLE = plain
+
+#---------------------------------------------------------------------------
+# Configuration options related to the RTF output
+#---------------------------------------------------------------------------
+
+# If the GENERATE_RTF tag is set to YES doxygen will generate RTF output. The
+# RTF output is optimized for Word 97 and may not look too pretty with other RTF
+# readers/editors.
+# The default value is: NO.
+
+GENERATE_RTF = NO
+
+# The RTF_OUTPUT tag is used to specify where the RTF docs will be put. If a
+# relative path is entered the value of OUTPUT_DIRECTORY will be put in front of
+# it.
+# The default directory is: rtf.
+# This tag requires that the tag GENERATE_RTF is set to YES.
+
+RTF_OUTPUT = rtf
+
+# If the COMPACT_RTF tag is set to YES doxygen generates more compact RTF
+# documents. This may be useful for small projects and may help to save some
+# trees in general.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_RTF is set to YES.
+
+COMPACT_RTF = NO
+
+# If the RTF_HYPERLINKS tag is set to YES, the RTF that is generated will
+# contain hyperlink fields. The RTF file will contain links (just like the HTML
+# output) instead of page references. This makes the output suitable for online
+# browsing using Word or some other Word compatible readers that support those
+# fields.
+#
+# Note: WordPad (write) and others do not support links.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_RTF is set to YES.
+
+RTF_HYPERLINKS = NO
+
+# Load stylesheet definitions from file. Syntax is similar to doxygen's config
+# file, i.e. a series of assignments. You only have to provide replacements,
+# missing definitions are set to their default value.
+#
+# See also section "Doxygen usage" for information on how to generate the
+# default style sheet that doxygen normally uses.
+# This tag requires that the tag GENERATE_RTF is set to YES.
+
+RTF_STYLESHEET_FILE =
+
+# Set optional variables used in the generation of an RTF document. Syntax is
+# similar to doxygen's config file. A template extensions file can be generated
+# using doxygen -e rtf extensionFile.
+# This tag requires that the tag GENERATE_RTF is set to YES.
+
+RTF_EXTENSIONS_FILE =
+
+#---------------------------------------------------------------------------
+# Configuration options related to the man page output
+#---------------------------------------------------------------------------
+
+# If the GENERATE_MAN tag is set to YES doxygen will generate man pages for
+# classes and files.
+# The default value is: NO.
+
+GENERATE_MAN = NO
+
+# The MAN_OUTPUT tag is used to specify where the man pages will be put. If a
+# relative path is entered the value of OUTPUT_DIRECTORY will be put in front of
+# it. A directory man3 will be created inside the directory specified by
+# MAN_OUTPUT.
+# The default directory is: man.
+# This tag requires that the tag GENERATE_MAN is set to YES.
+
+MAN_OUTPUT = man
+
+# The MAN_EXTENSION tag determines the extension that is added to the generated
+# man pages. In case the manual section does not start with a number, the number
+# 3 is prepended. The dot (.) at the beginning of the MAN_EXTENSION tag is
+# optional.
+# The default value is: .3.
+# This tag requires that the tag GENERATE_MAN is set to YES.
+
+MAN_EXTENSION = .3
+
+# If the MAN_LINKS tag is set to YES and doxygen generates man output, then it
+# will generate one additional man file for each entity documented in the real
+# man page(s). These additional files only source the real man page, but without
+# them the man command would be unable to find the correct page.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_MAN is set to YES.
+
+MAN_LINKS = NO
+
+#---------------------------------------------------------------------------
+# Configuration options related to the XML output
+#---------------------------------------------------------------------------
+
+# If the GENERATE_XML tag is set to YES doxygen will generate an XML file that
+# captures the structure of the code including all documentation.
+# The default value is: NO.
+
+GENERATE_XML = NO
+
+# The XML_OUTPUT tag is used to specify where the XML pages will be put. If a
+# relative path is entered the value of OUTPUT_DIRECTORY will be put in front of
+# it.
+# The default directory is: xml.
+# This tag requires that the tag GENERATE_XML is set to YES.
+
+XML_OUTPUT = xml
+
+# The XML_SCHEMA tag can be used to specify a XML schema, which can be used by a
+# validating XML parser to check the syntax of the XML files.
+# This tag requires that the tag GENERATE_XML is set to YES.
+
+XML_SCHEMA =
+
+# The XML_DTD tag can be used to specify a XML DTD, which can be used by a
+# validating XML parser to check the syntax of the XML files.
+# This tag requires that the tag GENERATE_XML is set to YES.
+
+XML_DTD =
+
+# If the XML_PROGRAMLISTING tag is set to YES doxygen will dump the program
+# listings (including syntax highlighting and cross-referencing information) to
+# the XML output. Note that enabling this will significantly increase the size
+# of the XML output.
+# The default value is: YES.
+# This tag requires that the tag GENERATE_XML is set to YES.
+
+XML_PROGRAMLISTING = YES
+
+#---------------------------------------------------------------------------
+# Configuration options related to the DOCBOOK output
+#---------------------------------------------------------------------------
+
+# If the GENERATE_DOCBOOK tag is set to YES doxygen will generate Docbook files
+# that can be used to generate PDF.
+# The default value is: NO.
+
+GENERATE_DOCBOOK = NO
+
+# The DOCBOOK_OUTPUT tag is used to specify where the Docbook pages will be put.
+# If a relative path is entered the value of OUTPUT_DIRECTORY will be put in
+# front of it.
+# The default directory is: docbook.
+# This tag requires that the tag GENERATE_DOCBOOK is set to YES.
+
+DOCBOOK_OUTPUT = docbook
+
+#---------------------------------------------------------------------------
+# Configuration options for the AutoGen Definitions output
+#---------------------------------------------------------------------------
+
+# If the GENERATE_AUTOGEN_DEF tag is set to YES doxygen will generate an AutoGen
+# Definitions (see http://autogen.sf.net) file that captures the structure of
+# the code including all documentation. Note that this feature is still
+# experimental and incomplete at the moment.
+# The default value is: NO.
+
+GENERATE_AUTOGEN_DEF = NO
+
+#---------------------------------------------------------------------------
+# Configuration options related to the Perl module output
+#---------------------------------------------------------------------------
+
+# If the GENERATE_PERLMOD tag is set to YES doxygen will generate a Perl module
+# file that captures the structure of the code including all documentation.
+#
+# Note that this feature is still experimental and incomplete at the moment.
+# The default value is: NO.
+
+GENERATE_PERLMOD = NO
+
+# If the PERLMOD_LATEX tag is set to YES doxygen will generate the necessary
+# Makefile rules, Perl scripts and LaTeX code to be able to generate PDF and DVI
+# output from the Perl module output.
+# The default value is: NO.
+# This tag requires that the tag GENERATE_PERLMOD is set to YES.
+
+PERLMOD_LATEX = NO
+
+# If the PERLMOD_PRETTY tag is set to YES the Perl module output will be nicely
+# formatted so it can be parsed by a human reader. This is useful if you want to
+# understand what is going on. On the other hand, if this tag is set to NO the
+# size of the Perl module output will be much smaller and Perl will parse it
+# just the same.
+# The default value is: YES.
+# This tag requires that the tag GENERATE_PERLMOD is set to YES.
+
+PERLMOD_PRETTY = YES
+
+# The names of the make variables in the generated doxyrules.make file are
+# prefixed with the string contained in PERLMOD_MAKEVAR_PREFIX. This is useful
+# so different doxyrules.make files included by the same Makefile don't
+# overwrite each other's variables.
+# This tag requires that the tag GENERATE_PERLMOD is set to YES.
+
+PERLMOD_MAKEVAR_PREFIX =
+
+#---------------------------------------------------------------------------
+# Configuration options related to the preprocessor
+#---------------------------------------------------------------------------
+
+# If the ENABLE_PREPROCESSING tag is set to YES doxygen will evaluate all
+# C-preprocessor directives found in the sources and include files.
+# The default value is: YES.
+
+ENABLE_PREPROCESSING = NO
+
+# If the MACRO_EXPANSION tag is set to YES doxygen will expand all macro names
+# in the source code. If set to NO only conditional compilation will be
+# performed. Macro expansion can be done in a controlled way by setting
+# EXPAND_ONLY_PREDEF to YES.
+# The default value is: NO.
+# This tag requires that the tag ENABLE_PREPROCESSING is set to YES.
+
+MACRO_EXPANSION = NO
+
+# If the EXPAND_ONLY_PREDEF and MACRO_EXPANSION tags are both set to YES then
+# the macro expansion is limited to the macros specified with the PREDEFINED and
+# EXPAND_AS_DEFINED tags.
+# The default value is: NO.
+# This tag requires that the tag ENABLE_PREPROCESSING is set to YES.
+
+EXPAND_ONLY_PREDEF = NO
+
+# If the SEARCH_INCLUDES tag is set to YES the includes files in the
+# INCLUDE_PATH will be searched if a #include is found.
+# The default value is: YES.
+# This tag requires that the tag ENABLE_PREPROCESSING is set to YES.
+
+SEARCH_INCLUDES = YES
+
+# The INCLUDE_PATH tag can be used to specify one or more directories that
+# contain include files that are not input files but should be processed by the
+# preprocessor.
+# This tag requires that the tag SEARCH_INCLUDES is set to YES.
+
+INCLUDE_PATH =
+
+# You can use the INCLUDE_FILE_PATTERNS tag to specify one or more wildcard
+# patterns (like *.h and *.hpp) to filter out the header-files in the
+# directories. If left blank, the patterns specified with FILE_PATTERNS will be
+# used.
+# This tag requires that the tag ENABLE_PREPROCESSING is set to YES.
+
+INCLUDE_FILE_PATTERNS =
+
+# The PREDEFINED tag can be used to specify one or more macro names that are
+# defined before the preprocessor is started (similar to the -D option of e.g.
+# gcc). The argument of the tag is a list of macros of the form: name or
+# name=definition (no spaces). If the definition and the "=" are omitted, "=1"
+# is assumed. To prevent a macro definition from being undefined via #undef or
+# recursively expanded use the := operator instead of the = operator.
+# This tag requires that the tag ENABLE_PREPROCESSING is set to YES.
+
+PREDEFINED =
+
+# If the MACRO_EXPANSION and EXPAND_ONLY_PREDEF tags are set to YES then this
+# tag can be used to specify a list of macro names that should be expanded. The
+# macro definition that is found in the sources will be used. Use the PREDEFINED
+# tag if you want to use a different macro definition that overrules the
+# definition found in the source code.
+# This tag requires that the tag ENABLE_PREPROCESSING is set to YES.
+
+EXPAND_AS_DEFINED =
+
+# If the SKIP_FUNCTION_MACROS tag is set to YES then doxygen's preprocessor will
+# remove all refrences to function-like macros that are alone on a line, have an
+# all uppercase name, and do not end with a semicolon. Such function macros are
+# typically used for boiler-plate code, and will confuse the parser if not
+# removed.
+# The default value is: YES.
+# This tag requires that the tag ENABLE_PREPROCESSING is set to YES.
+
+SKIP_FUNCTION_MACROS = YES
+
+#---------------------------------------------------------------------------
+# Configuration options related to external references
+#---------------------------------------------------------------------------
+
+# The TAGFILES tag can be used to specify one or more tag files. For each tag
+# file the location of the external documentation should be added. The format of
+# a tag file without this location is as follows:
+# TAGFILES = file1 file2 ...
+# Adding location for the tag files is done as follows:
+# TAGFILES = file1=loc1 "file2 = loc2" ...
+# where loc1 and loc2 can be relative or absolute paths or URLs. See the
+# section "Linking to external documentation" for more information about the use
+# of tag files.
+# Note: Each tag file must have an unique name (where the name does NOT include
+# the path). If a tag file is not located in the directory in which doxygen is
+# run, you must also specify the path to the tagfile here.
+
+TAGFILES =
+
+# When a file name is specified after GENERATE_TAGFILE, doxygen will create a
+# tag file that is based on the input files it reads. See section "Linking to
+# external documentation" for more information about the usage of tag files.
+
+GENERATE_TAGFILE =
+
+# If the ALLEXTERNALS tag is set to YES all external class will be listed in the
+# class index. If set to NO only the inherited external classes will be listed.
+# The default value is: NO.
+
+ALLEXTERNALS = NO
+
+# If the EXTERNAL_GROUPS tag is set to YES all external groups will be listed in
+# the modules index. If set to NO, only the current project's groups will be
+# listed.
+# The default value is: YES.
+
+EXTERNAL_GROUPS = YES
+
+# If the EXTERNAL_PAGES tag is set to YES all external pages will be listed in
+# the related pages index. If set to NO, only the current project's pages will
+# be listed.
+# The default value is: YES.
+
+EXTERNAL_PAGES = YES
+
+# The PERL_PATH should be the absolute path and name of the perl script
+# interpreter (i.e. the result of 'which perl').
+# The default file (with absolute path) is: /usr/bin/perl.
+
+PERL_PATH = /usr/bin/perl
+
+#---------------------------------------------------------------------------
+# Configuration options related to the dot tool
+#---------------------------------------------------------------------------
+
+# If the CLASS_DIAGRAMS tag is set to YES doxygen will generate a class diagram
+# (in HTML and LaTeX) for classes with base or super classes. Setting the tag to
+# NO turns the diagrams off. Note that this option also works with HAVE_DOT
+# disabled, but it is recommended to install and use dot, since it yields more
+# powerful graphs.
+# The default value is: YES.
+
+CLASS_DIAGRAMS = YES
+
+# You can define message sequence charts within doxygen comments using the \msc
+# command. Doxygen will then run the mscgen tool (see:
+# http://www.mcternan.me.uk/mscgen/)) to produce the chart and insert it in the
+# documentation. The MSCGEN_PATH tag allows you to specify the directory where
+# the mscgen tool resides. If left empty the tool is assumed to be found in the
+# default search path.
+
+MSCGEN_PATH =
+
+# If set to YES, the inheritance and collaboration graphs will hide inheritance
+# and usage relations if the target is undocumented or is not a class.
+# The default value is: YES.
+
+HIDE_UNDOC_RELATIONS = YES
+
+# If you set the HAVE_DOT tag to YES then doxygen will assume the dot tool is
+# available from the path. This tool is part of Graphviz (see:
+# http://www.graphviz.org/), a graph visualization toolkit from AT&T and Lucent
+# Bell Labs. The other options in this section have no effect if this option is
+# set to NO
+# The default value is: NO.
+
+HAVE_DOT = YES
+
+# The DOT_NUM_THREADS specifies the number of dot invocations doxygen is allowed
+# to run in parallel. When set to 0 doxygen will base this on the number of
+# processors available in the system. You can set it explicitly to a value
+# larger than 0 to get control over the balance between CPU load and processing
+# speed.
+# Minimum value: 0, maximum value: 32, default value: 0.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+DOT_NUM_THREADS = 0
+
+# When you want a differently looking font n the dot files that doxygen
+# generates you can specify the font name using DOT_FONTNAME. You need to make
+# sure dot is able to find the font, which can be done by putting it in a
+# standard location or by setting the DOTFONTPATH environment variable or by
+# setting DOT_FONTPATH to the directory containing the font.
+# The default value is: Helvetica.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+DOT_FONTNAME = Helvetica
+
+# The DOT_FONTSIZE tag can be used to set the size (in points) of the font of
+# dot graphs.
+# Minimum value: 4, maximum value: 24, default value: 10.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+DOT_FONTSIZE = 10
+
+# By default doxygen will tell dot to use the default font as specified with
+# DOT_FONTNAME. If you specify a different font using DOT_FONTNAME you can set
+# the path where dot can find it using this tag.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+DOT_FONTPATH =
+
+# If the CLASS_GRAPH tag is set to YES then doxygen will generate a graph for
+# each documented class showing the direct and indirect inheritance relations.
+# Setting this tag to YES will force the CLASS_DIAGRAMS tag to NO.
+# The default value is: YES.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+CLASS_GRAPH = YES
+
+# If the COLLABORATION_GRAPH tag is set to YES then doxygen will generate a
+# graph for each documented class showing the direct and indirect implementation
+# dependencies (inheritance, containment, and class references variables) of the
+# class with other documented classes.
+# The default value is: YES.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+COLLABORATION_GRAPH = YES
+
+# If the GROUP_GRAPHS tag is set to YES then doxygen will generate a graph for
+# groups, showing the direct groups dependencies.
+# The default value is: YES.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+GROUP_GRAPHS = YES
+
+# If the UML_LOOK tag is set to YES doxygen will generate inheritance and
+# collaboration diagrams in a style similar to the OMG's Unified Modeling
+# Language.
+# The default value is: NO.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+UML_LOOK = NO
+
+# If the UML_LOOK tag is enabled, the fields and methods are shown inside the
+# class node. If there are many fields or methods and many nodes the graph may
+# become too big to be useful. The UML_LIMIT_NUM_FIELDS threshold limits the
+# number of items for each type to make the size more manageable. Set this to 0
+# for no limit. Note that the threshold may be exceeded by 50% before the limit
+# is enforced. So when you set the threshold to 10, up to 15 fields may appear,
+# but if the number exceeds 15, the total amount of fields shown is limited to
+# 10.
+# Minimum value: 0, maximum value: 100, default value: 10.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+UML_LIMIT_NUM_FIELDS = 10
+
+# If the TEMPLATE_RELATIONS tag is set to YES then the inheritance and
+# collaboration graphs will show the relations between templates and their
+# instances.
+# The default value is: NO.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+TEMPLATE_RELATIONS = NO
+
+# If the INCLUDE_GRAPH, ENABLE_PREPROCESSING and SEARCH_INCLUDES tags are set to
+# YES then doxygen will generate a graph for each documented file showing the
+# direct and indirect include dependencies of the file with other documented
+# files.
+# The default value is: YES.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+INCLUDE_GRAPH = YES
+
+# If the INCLUDED_BY_GRAPH, ENABLE_PREPROCESSING and SEARCH_INCLUDES tags are
+# set to YES then doxygen will generate a graph for each documented file showing
+# the direct and indirect include dependencies of the file with other documented
+# files.
+# The default value is: YES.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+INCLUDED_BY_GRAPH = YES
+
+# If the CALL_GRAPH tag is set to YES then doxygen will generate a call
+# dependency graph for every global function or class method.
+#
+# Note that enabling this option will significantly increase the time of a run.
+# So in most cases it will be better to enable call graphs for selected
+# functions only using the \callgraph command.
+# The default value is: NO.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+CALL_GRAPH = YES
+
+# If the CALLER_GRAPH tag is set to YES then doxygen will generate a caller
+# dependency graph for every global function or class method.
+#
+# Note that enabling this option will significantly increase the time of a run.
+# So in most cases it will be better to enable caller graphs for selected
+# functions only using the \callergraph command.
+# The default value is: NO.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+CALLER_GRAPH = YES
+
+# If the GRAPHICAL_HIERARCHY tag is set to YES then doxygen will graphical
+# hierarchy of all classes instead of a textual one.
+# The default value is: YES.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+GRAPHICAL_HIERARCHY = YES
+
+# If the DIRECTORY_GRAPH tag is set to YES then doxygen will show the
+# dependencies a directory has on other directories in a graphical way. The
+# dependency relations are determined by the #include relations between the
+# files in the directories.
+# The default value is: YES.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+DIRECTORY_GRAPH = YES
+
+# The DOT_IMAGE_FORMAT tag can be used to set the image format of the images
+# generated by dot.
+# Note: If you choose svg you need to set HTML_FILE_EXTENSION to xhtml in order
+# to make the SVG files visible in IE 9+ (other browsers do not have this
+# requirement).
+# Possible values are: png, jpg, gif and svg.
+# The default value is: png.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+DOT_IMAGE_FORMAT = png
+
+# If DOT_IMAGE_FORMAT is set to svg, then this option can be set to YES to
+# enable generation of interactive SVG images that allow zooming and panning.
+#
+# Note that this requires a modern browser other than Internet Explorer. Tested
+# and working are Firefox, Chrome, Safari, and Opera.
+# Note: For IE 9+ you need to set HTML_FILE_EXTENSION to xhtml in order to make
+# the SVG files visible. Older versions of IE do not have SVG support.
+# The default value is: NO.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+INTERACTIVE_SVG = NO
+
+# The DOT_PATH tag can be used to specify the path where the dot tool can be
+# found. If left blank, it is assumed the dot tool can be found in the path.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+DOT_PATH =
+
+# The DOTFILE_DIRS tag can be used to specify one or more directories that
+# contain dot files that are included in the documentation (see the \dotfile
+# command).
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+DOTFILE_DIRS =
+
+# The MSCFILE_DIRS tag can be used to specify one or more directories that
+# contain msc files that are included in the documentation (see the \mscfile
+# command).
+
+MSCFILE_DIRS =
+
+# The DOT_GRAPH_MAX_NODES tag can be used to set the maximum number of nodes
+# that will be shown in the graph. If the number of nodes in a graph becomes
+# larger than this value, doxygen will truncate the graph, which is visualized
+# by representing a node as a red box. Note that doxygen if the number of direct
+# children of the root node in a graph is already larger than
+# DOT_GRAPH_MAX_NODES then the graph will not be shown at all. Also note that
+# the size of a graph can be further restricted by MAX_DOT_GRAPH_DEPTH.
+# Minimum value: 0, maximum value: 10000, default value: 50.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+DOT_GRAPH_MAX_NODES = 100
+
+# The MAX_DOT_GRAPH_DEPTH tag can be used to set the maximum depth of the graphs
+# generated by dot. A depth value of 3 means that only nodes reachable from the
+# root by following a path via at most 3 edges will be shown. Nodes that lay
+# further from the root node will be omitted. Note that setting this option to 1
+# or 2 may greatly reduce the computation time needed for large code bases. Also
+# note that the size of a graph can be further restricted by
+# DOT_GRAPH_MAX_NODES. Using a depth of 0 means no depth restriction.
+# Minimum value: 0, maximum value: 1000, default value: 0.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+MAX_DOT_GRAPH_DEPTH = 5
+
+# Set the DOT_TRANSPARENT tag to YES to generate images with a transparent
+# background. This is disabled by default, because dot on Windows does not seem
+# to support this out of the box.
+#
+# Warning: Depending on the platform used, enabling this option may lead to
+# badly anti-aliased labels on the edges of a graph (i.e. they become hard to
+# read).
+# The default value is: NO.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+DOT_TRANSPARENT = NO
+
+# Set the DOT_MULTI_TARGETS tag to YES allow dot to generate multiple output
+# files in one run (i.e. multiple -o and -T options on the command line). This
+# makes dot run faster, but since only newer versions of dot (>1.8.10) support
+# this, this feature is disabled by default.
+# The default value is: NO.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+DOT_MULTI_TARGETS = YES
+
+# If the GENERATE_LEGEND tag is set to YES doxygen will generate a legend page
+# explaining the meaning of the various boxes and arrows in the dot generated
+# graphs.
+# The default value is: YES.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+GENERATE_LEGEND = YES
+
+# If the DOT_CLEANUP tag is set to YES doxygen will remove the intermediate dot
+# files that are used to generate the various graphs.
+# The default value is: YES.
+# This tag requires that the tag HAVE_DOT is set to YES.
+
+DOT_CLEANUP = YES
diff --git a/doc/doc_image/cube.png b/doc/doc_image/cube.png
new file mode 100644
index 0000000000000000000000000000000000000000..e9e570bb2b70f4922200cf8b19171e2b3a14e50e
GIT binary patch
literal 4345
zcmeAS@N?(olHy`uVBq!ia0y~yU@T-{U^v9V#K6E{a3*yQ0|NtNage(c!@6@aFBupZ
zI14-?iy0WWg+Z8+Vb&Z81_lQ95>H=O_FG(h{N^Gd^H1_KFfhnwhD4M&=jZ08=9Msj
zfOAo5Vo7R>LV0FMhJw4NZ$OG(Dmw#%K$546V@SoVw{ve#d%c3sbu!Pt|I>flglzY3
zOHO9o#TeXQy}agN(k2y$J^z0`pD*6#oA>_v?=SimWjD4jc)9Uw15+f^TW8^f>PKwG
zo1BF2R4O{l$cr><N-#Zn=&!)-bI{<d0NYKb;0f2Ze3;G89&Dha?B3Ct;I;hu&mZi?
zT-v5@zWYApwmLf7^n%LfzqL;%<{#m*nsI4O(beS48a>Ws{rrZ0(`>pbHu>+2SX}bs
z!b(=T!ov#FcvUBT^H<U>FPM6@q)Udy#WtH`^7NeCed}^IR=;Ll5L|HoRQz2}i6@>S
z?oqe@yqmmKR$7HWto(F=U#`{kKXZc|kEl&oR9;(K^TK<s(L1)_EpJsL-a7p-{jO?m
z`YWIN&$5sJjmD1&@!8(b+B#Eo*-meoTJPQT>hk|bWq}%!<sXml|NHM?r{nFq@7`kO
zzSUFjHcVoCvf#*;%HP+H&a3-x`=_RSt;)`OD))bxKi}c^M)~=R#VX4V_=^NA$}oE5
z=XoV&Rl!P~mrup!%2!SjQ=MuUJkjg@_voVTzALwr?r6TQtbD3n_WmV<#!1GttW!?8
z)-9g5Tb{oyRykhra7yLHq+B6!ai*oe`=SpX&7GM2pggno_<O(VqzQNbJ?qonzAo`%
zO;n<vqJR7=zOpAuN7b+Imh+kuofa^Ag~EZVFQLz;u*S%J(zJBm{c+Dqv4AZp-zF{W
zojptXP3A7yuUppWsr%YoPIRq!e4tOnLa<nT?z%?NuWJvKJ0A2h*(svtzRJ~*#rtW3
zukj1j%}y5=bzU=@JoVG(vgrJGVF!=1Sw~Iuv+dLl$;xAqyuZwTivPqMu7c#{k9Z1S
zYhT&_o$2a<Kjxo8Z>`l-<DIVlN&CvfM~jQEHY&ZDy7b@T%Sulj&aP*g5@J=;Xt4Y}
zzx>ZnKl)cb@eIB)$9HOkP0-9m%s(_l5-*>h8qK-fGyB4qT{o*PKM~a`3d+{{d*0bE
zd2{QX-OSt1r`sAoH7tHO!OK8(*B`6p=l}n1-<)G`djBq$Pd7wU{^uRzESY^=eM*k-
z#E|NVd-4?ms!F<kZJ1L~-&<gxown)BreiMinlpZJJ&s$o>BrK4dZLkqRa;MY_lOj1
zi0!!XaY0vbq2=7_GVYV#`t5IcOi<EnddwiQc6M3&+hq=d@7gqP%E(Sxv)1=c*{?0{
zYIf@6J#bj$%@dk5^Zp_3hjU-=ad)gcZO7I;X^Y9ncu9eMr61mXZ#KF!*`;x^wbRU-
zo0DQ)I~gYm%&IWk{W7TbXy>2%!SkP-HMMI_zIDFTe(wa$qc^WRp1kEL+-};qYsIf=
zoYQCXy!zO&c}3@<lZCP;eV1<ZKkgZIGSevY=Bq7<eVGl(U-Wznk89RHoLTIt>L>ry
zsqn+6ty?>9JDohE8L_yv{-)NXKkK5aP2csDvvnPfT6H{I>||_u%$o$;l&${`q%+wq
z`J2wtbxMu-;Z>)MPrGI+78yLPIdx@{%0sQ+e@wPBdujQF{`(M7oBu_rd1BxHP4749
z2IxKiw!8LRQfh9z*tfj$o+rtssn?>v&p2`3U;{(f%aZr1VOO%Zp1H(+zyEghllJg4
z+Ce&LD}AOr^;J)`;WepPu~<dUWUi`={^KjN3?==wUZ*{({dW1!|7<hQ#V@<AXPI7p
zz$(hU`1mv5H+kyewrfk|{&dtX-)BBGTf&AZFrw$?!WD1t>vp*w`Fgiwv%vFDfp@i*
zJejX(w)gJR<K}ClHr$xIhG|Ne<+Mt{Wal@^H8TqnZMr7}Uevjp$`ZU#rE+W5ZuWP~
zUO84~oqm=4V%sF`ckY^Wx5lUD-rbG=R3`0O`1sSRtzQo{K8g_wp03uP>G+!c@~Ym1
z=gfQ&nF(In<$BgBx3ZK)%Vj*b^-e!ixWLn+GWPCTtGk~fR|l<m{->`vZ^frsbA2{m
zm=hf0Q9Z>^xp%VTY!~0FkvV_3`wMCx$-bT(9sPfg&_5B^@`*Nue>b+w-I*MA$z;vc
zcoi*X@qIfrMSZm%ZS34;=Wy}TkFQ%RyYi(XAMg6jk)3F}FK3bFl4G%NUM=KVdD+h6
z>dDkXy;ac%vTZr07V4d;o)lKw7;kpvTV?v1;8lk&zWo!hd(z>br<e0J?cQN}L1#+f
z`}w}AzuB$bCMmb;ERzs<yv)w^&+464T;I!?kLDWBvgs`RuJ^Q6lK;or?%lKB{j2`i
z$#uW_(aEINf9t3HeCqAKO#j0V@u}C^H2oePUf>_{&*rdXn%gfAL5;G~520E)?L3@r
z*>|qa*mQ%<X=-NciUSw^Tigq|-LZAu<gC~?C)V`d4tHK&F=yGHAc>^fr#7FSOs!t{
z_rc_desk5?@<*cH+}stIAsp6T{=s8+$(rTH%e%_;xOdO^lpQ~J5y$(R>idmCM6R7Z
z@j^?aa-DAUHx;#=(+a#-)QcO%YA)Y>%)Gzj@+<pSCY3+miG1`qUMBu)dq%;tNu>=+
zB_dOEm)(>|F)3BeH>`9neG?{sg=uBjrmHI#?!FN}U$eM(?=pv#-+TL3rTQj**rVj}
z?@8I`kJ?|GKAd^B@2ALD-;BWKpzU^t{`@_gxXRFm_2bFQuFDy^oZrql`2EqB8!hL`
z7>??7e=IND9`x#k$a24XR?oA(*c?(`BVc-Y=bgLZ*-NLsyq;cr%EWQ&HLp{LFN$*W
z2=A}plUP1^_GVYkH{T5<>n}YDE&3CxopkMljQzeJADK@o*x&7%=i+lS%qiUK<=Q3J
z+3qjRpS5TAm1TPr&UxHj?|33BSJnG<+7<uKo~ke|iP>$w+b{7dW)@v$j99%vGy9%U
z?``*BsoacvVOMnSGim)6`m8V2pn17OOGVM4bLqAV%q!;`sf0e!U9hNHkjdKp+Qazx
zN&ERNx|2iKT)1thJnPQYiQI1rzh2z<;$EiqnllnRRpuKV_@sUL_?&a?=gm$}*vicD
z=}gax``f=>-BkPWd;PZ`AzZJ6<CgFn>Im<@@-*vm|3yuSBz0MRmD-A%rujFLE*gpH
z+1BiN6u7EHpI5&tw=wefoNH`Om$tYCop?Us^OJLKZ<<#qK00uvVNs0v{Du6Q?LDtv
ztO$Jn`|g#l*$F3?`v^D*uUf;kjOQ!YmCqIis;(Brk=49?Ix??$FS&@%+BNT()h(BT
zl~+<W+BvbzR!v+e*R$H5)9UEg-&YqFgj+rNl(Oe#U)JFu#-n*#S1|>9{9tGEUC(*G
z@lH(%C%aeb8mHw6>6Xc|TGebnzc&6YEcShxsB$WByW!+3eW8D>rhZF5dwbR+)!F8!
z=RV(*ynWeZtE`W;?UUCxI<sn(-%)(HBGR7qwB?~cyw`7@2zt4<{=cc6?xkB9vd;}e
z{Zh}xEIx4S)B^T|Jj2$!f+z34JLyLyoV~rx;pcAGz#5AJ<G^P}*S#*2uTMPk$o8($
z2EN3X)iED7uKFWs&%krP<E`n#!o0v7g$QGD-@5)cc26~}6E^xEvU@%|?M1Wei>6(S
zmfl((EC~-C47+&kmF=#t+SE5`T1_3#?C^y*uALQUN{a4#;u(?T`RMG^`(G|!G_fpq
zPP(z}V6s-!)OXvY12rzB#PuI6;7^@<iRI<#m0r8pw-x^|whoXx{Imb=S&g5L7urw$
zPGR?AYn+r9UnILrM!hF-S<ul+!MS^s#k<*<G$hP+-{Q5t|9s+Z2G-kJ>k11hUQd;r
zTADs-tDyX4aW)N!X_C?VEiat*mG*V}JB9O3(`4q2(+@s7@cx!nm(_xZJ!VR*(f4+3
zUR$f&veM?_+f{RNyArLBS-Up~?`hw_d29#M+XhvZuCKc;_j_$$_∋j>E>fw5>H<
z5eGNyY`8RwU+CYw8m_jts{?eFF!&tY@Uvmks}JWdFWzK#^p54L|9)pWW@=5D{`+3)
z456NHyQeZar2D5ViM^w-K7u1y=;g8ZuD$yUEOi$zxe<EK&aA?5{^eyCHLX8A{nFo_
zekEM1{<rFdo0j)DLu_4NUo5=oSZ4FDGiB=~b6>gdQ|IlIdb)%8tDi^!+rr|X+f(N#
zm;dk3S4+9}vLd)MI+!=zs#0msryox)K8-!q^R`ueWx?|bp3ZL*p9_}Bg{!>(eRnc*
zqmv!$?8Ud|?5XUniv4tO&$^c)nb8Z~esqLxsd+8EcaBL1C!-0g`xDXg@6tZjF`wrV
zvWV?{&3a6JyFhbU#wX##{5LoDDybjc!QU=3F;Uz{@OOe?^6wq~@o`T!t@h@twtV=~
zQ13HiW7WfbD=OS8@1=_gcCTHP@q{yQ``hBri()R`aPCO_&2-d>SHrl~=agEq;I_7K
zpMcj53LJ;c<kLE8&)D1a9(cY_gyZhMg+@m&w=7v!{nCInvQKcX@0D|F#WN4xcYkgB
z^Tx7cR^o3gR1AI=3;jNznIlzM#Gv|ld$XqD+?j3<l=am7*UWIrKPbfa{`85-0-d+C
zI=JQwJl_30=h6qqUHW^H_Vc$bU0lHCR{lJDhWD`zZ(ZVp6Lm|t+{%^iNnT=fT5u<p
zaan?dO(^rJZqs}V!?yyDJ};j+J+<LeQZ3itcyABmbv|DTckiE`lC*n;y|!MH!-Bc9
zOB^3Ko8?xC{1ckn<ajcnbGuMLTv>YC!$gUO2?00ckFO2%fBo3-eY0ZOwff-mIpQ17
zZ#s4D>{`y6C$Z)!&JQ>OtmL+?xgKqxqyExK?xdu~5jzPnPLazKQfgRz@5>(&={c}`
z^J&wm+&i+D@~E@Fvg7obd9u0FJUwL{tHrAm8|K|?)D-4<KmB>Wo!q<KardJiH`dz4
zJl*nAW7dHwE`C4HPCRw<K%@H~tA+&Lyfz&h&gUFHo$pK44U2xntG?P7a*@4xk(J8B
z8?nt6TYM5Ou`Kg>&?I#5&+qrgC;WIF_vPDG<*joZ8Z{*!UJ{%T|L@s5B}uNi_l|OB
z>Ras2`dni$!-z5dms;&Rg;Gg}lY2jWdHkNen&-;}HAVkNcm5fqs_n~gT-7IGsla#d
z>iWlbq_?_wEuG5rbCQgP0jr<pkEFlTC%vAtqgbU=r|R?%wt82~YpWcB&%Qq(qGNRN
zg5XM9yY%3wszxmtp#>=w)-#y+E<F`*Ss!`RZu32z856UbHG|zGwQBvJTD=N6buCb~
z%%CMDNR8=K_b*L}U)loewcgKL`!#_pc6#|7i&vgM_8FvJTjKmCd4uPz<;ni+A~QA#
z&Mx{TpA*HSVbFST!U6T5ce<6=q<jt<xN!O03@YRi(+-p2=Zs+B@=^S7(<EwUpF;ob
z#h<oIWZyGzFjykX7QHw#`;mw)fAF&x(|BIqcC)%HxshKa`r*W9sp~E}zA#{QUa}w{
zjDgGN;DuMt*X~}O?G<{~bkPBkGb_a-H)o1n+A6khw%?*ji&g(bGWuVu^=FOvdD?DK
z@B}vA@C#DMLSJkP{qp7C`7#DBE7plZ-&AJ%{Cd+YRKm55Pib-4qpSCmv~!#MZmwfr
zCUsJGp33>#rI&MO)=2u?JS4=X<Ne6)ZRKJE*4b+D4{Q$IpIbR&VJ*X{{cjJPn7n+x
z&tI{%`l5AH+P%1K=Dpsv@R9TKCvP`4<}ELJ=l<jHZqo;=w39AscK3X6yLYnb*F?4}
zR!cJ5+gz7BXiHt#w*9?X&S4Rr&5uscb7aWAXYl5XxRPuM*S1-vp&=%rdbJrhEPXxu
zu7!rn-!scMTk^<YqqoOrlb6qGxt1+q6R=HL$F{`$;1t=;&0BT0tMJ8gE=ypLT5v#w
z=k#%LtBczW-!~`zy<KKd!qrxKYT9m2>#7SU|FKWBtkR13Io}L44B_eO=d#Wzp$Pz7
CtX9YX
literal 0
HcmV?d00001
diff --git a/forward/alloc_arrays.f90 b/forward/alloc_arrays.f90
new file mode 100644
index 0000000..251d8a0
--- /dev/null
+++ b/forward/alloc_arrays.f90
@@ -0,0 +1,423 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief allocate all global main arrays (dynamic size)
+!> @param[in] ismpl local sample index
+!> @details
+!> an additional ccNUMA initialisation is performed after the allocation,\n
+!> see "numa_init"\n
+ SUBROUTINE alloc_arrays(ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_data
+ use mod_time
+ use mod_conc
+ use mod_blocking_size
+ use mod_linfos
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i
+ INCLUDE 'OMP_TOOLS.inc'
+ INTEGER l2
+! thread stuff
+ ! INTEGER tpos, tanz
+ INTEGER mfactor
+! only for benchmarking
+#ifdef BENCH
+ DOUBLE PRECISION trun, tend
+#endif
+
+!
+ IF (linfos(1)>=2) WRITE(*,*) ' [I] : ... alloc_arrays'
+#ifdef BENCH
+ CALL sys_cputime(trun)
+#endif
+
+! single system size (factor == 1)
+ mfactor = 1
+
+ ALLOCATE(project_sfx(nsmpl))
+ DO i = 1, nsmpl
+ project_sfx(i) = ''
+ END DO
+
+ ALLOCATE(propunit(nunits,nprop,nsmpl))
+ memory = memory + nunits*nprop*nsmpl
+ CALL set_dval(nunits*nprop*nsmpl,0.D0,propunit)
+
+! temporary convergence list
+ ALLOCATE(conc_conv(ntrac,nsmpl))
+ memory = memory + ntrac*nsmpl
+
+ ALLOCATE(node_info(i0,j0,k0))
+ memory = memory + i0*j0*k0
+! additional global & private vectors for linear system solver
+! global buffer for boundary exchange (+ismpl)
+ ALLOCATE(lss_bound_block(block_i*block_j+block_i*block_k+ block_j*block_k,bdim_i,bdim_j,bdim_k,2,nsmpl))
+ memory = memory + (block_i*block_j+block_i*block_k+block_j*block_k)*bdim_i*bdim_j*bdim_k*2*nsmpl
+ ALLOCATE(lss_dnrm(i0*j0*k0*mfactor,nsmpl))
+ memory = memory + i0*j0*k0*mfactor*nsmpl
+ ALLOCATE(lss_tmp(i0*j0*k0,nsmpl))
+ memory = memory + i0*j0*k0*nsmpl
+! private copy for preconditioning (+Tlevel_1 +ismpl)
+ ALLOCATE(lss_lma(max_blocks*block_i*block_j*block_k,tlevel_1, nsmpl))
+ memory = memory + max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
+ ALLOCATE(lss_lmb(max_blocks*block_i*block_j*block_k,tlevel_1, nsmpl))
+ memory = memory + max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
+ ALLOCATE(lss_lmc(max_blocks*block_i*block_j*block_k,tlevel_1, nsmpl))
+ memory = memory + max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
+ ALLOCATE(lss_lmd(max_blocks*block_i*block_j*block_k,tlevel_1, nsmpl))
+ memory = memory + max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
+ ALLOCATE(lss_lme(max_blocks*block_i*block_j*block_k,tlevel_1, nsmpl))
+ memory = memory + max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
+ ALLOCATE(lss_lmf(max_blocks*block_i*block_j*block_k,tlevel_1, nsmpl))
+ memory = memory + max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
+ ALLOCATE(lss_lmg(max_blocks*block_i*block_j*block_k,tlevel_1, nsmpl))
+ memory = memory + max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
+ ALLOCATE(lss_lud(max_blocks*block_i*block_j*block_k,tlevel_1, nsmpl))
+ memory = memory + max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
+ ALLOCATE(lss_lx(max_blocks*block_i*block_j*block_k,tlevel_1, nsmpl))
+ memory = memory + max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
+ ALLOCATE(lss_lb(max_blocks*block_i*block_j*block_k,tlevel_1, nsmpl))
+ memory = memory + max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
+!
+ ALLOCATE(lss_lloctmp(max_blocks*block_i*block_j*block_k, max_loctmp,tlevel_1,nsmpl))
+ memory = memory + max_blocks*block_i*block_j*block_k*max_loctmp*tlevel_1*nsmpl
+!
+ ALLOCATE(lss_ldnrm(max_blocks*block_i*block_j*block_k, tlevel_1,nsmpl))
+ memory = memory + max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
+ ALLOCATE(lss_ud_block(block_i*block_j+block_i*block_k+ block_j*block_k,max_blocks,tlevel_1,nsmpl))
+ memory = memory + (block_i*block_j+block_i*block_k+block_j*block_k)*max_blocks*tlevel_1*nsmpl
+ ALLOCATE(lss_lr0_hat(max_blocks*block_i*block_j*block_k, tlevel_1,nsmpl))
+ memory = memory + max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
+! sanity check
+ IF (max_blocks*block_i*block_j*block_k*tlevel_1<i0*j0*k0*mfactor) THEN
+! when fewer than I0*J0*K0 memory is allocated,
+! then we have lost some elements in "par_init2(I0,J0,K0)"
+ WRITE(*,'(1A)') 'error: software bug, something goes wrong in "alloc_arrays"!'
+ STOP
+ END IF
+
+!
+! variables for variable time stepping
+ allocate(flag_delt(nsmpl))
+ memory = memory + nsmpl
+ ALLOCATE(delt_count(nsmpl))
+ memory = memory + nsmpl
+ allocate(flag_1st_timestep(nsmpl))
+ memory = memory + nsmpl
+ allocate(delt_old(nsmpl))
+ memory = memory + nsmpl
+!
+
+!
+! coefficients for linear equations
+ ALLOCATE(a(i0,j0,k0*mfactor,nsmpl))
+ memory = memory + i0*j0*k0*mfactor*nsmpl
+ ALLOCATE(b(i0,j0,k0*mfactor,nsmpl))
+ memory = memory + i0*j0*k0*mfactor*nsmpl
+ ALLOCATE(c(i0,j0,k0*mfactor,nsmpl))
+ memory = memory + i0*j0*k0*mfactor*nsmpl
+ ALLOCATE(d(i0,j0,k0*mfactor,nsmpl))
+ memory = memory + i0*j0*k0*mfactor*nsmpl
+ ALLOCATE(e(i0,j0,k0*mfactor,nsmpl))
+ memory = memory + i0*j0*k0*mfactor*nsmpl
+ ALLOCATE(f(i0,j0,k0*mfactor,nsmpl))
+ memory = memory + i0*j0*k0*mfactor*nsmpl
+ ALLOCATE(g(i0,j0,k0*mfactor,nsmpl))
+ memory = memory + i0*j0*k0*mfactor*nsmpl
+! formerly the solution vector - linear system, now a temporary helper vector
+ ALLOCATE(x(i0,j0,k0*mfactor,nsmpl))
+ memory = memory + i0*j0*k0*mfactor*nsmpl
+! only for ilu-precond. (shadow vectors)
+ ALLOCATE(ud(i0,j0,k0*mfactor,nsmpl))
+ memory = memory + i0*j0*k0*mfactor*nsmpl
+! rhs
+ ALLOCATE(w(i0,j0,k0*mfactor,nsmpl))
+ memory = memory + i0*j0*k0*mfactor*nsmpl
+! r0_hat for BiCGstab
+ ALLOCATE(r(i0,j0,k0*mfactor))
+ memory = memory + i0*j0*k0*mfactor
+! Dirichlet mask for special diagonal preconditioning
+ ALLOCATE(bc_mask(i0*j0*k0*mfactor,nsmpl))
+ memory = memory + i0*j0*k0*mfactor*nsmpl
+
+! state variables
+ ALLOCATE(head(i0,j0,k0,nsmpl))
+ memory = memory + i0*j0*k0*nsmpl
+ ALLOCATE(temp(i0,j0,k0,nsmpl))
+ memory = memory + i0*j0*k0*nsmpl
+ ALLOCATE(conc(i0,j0,k0,max(ntrans,1),nsmpl))
+ memory = memory + i0*j0*k0*max(ntrans,1)*nsmpl
+ ALLOCATE(pres(i0,j0,k0,nsmpl))
+ memory = memory + i0*j0*k0*nsmpl
+ ALLOCATE(tsal(i0,j0,k0,nsmpl))
+ memory = memory + i0*j0*k0*nsmpl
+
+! uindex(allocated in read_model)
+! memory = memory + i0*j0*k0
+
+! inverse
+ ALLOCATE(headold(i0*j0*k0,ncgen,nsmpl))
+ memory = memory + i0*j0*k0*ncgen*nsmpl
+ ALLOCATE(tempold(i0*j0*k0,ncgen,nsmpl))
+ memory = memory + i0*j0*k0*ncgen*nsmpl
+ ALLOCATE(concold(i0*j0*k0,max(ntrans,1),ncgen,nsmpl))
+ memory = memory + i0*j0*k0*ncgen*nsmpl*max(ntrans,1)
+ ALLOCATE(presold(i0*j0*k0,ncgen,nsmpl))
+ memory = memory + i0*j0*k0*ncgen*nsmpl
+
+ ALLOCATE(delx(i0))
+ memory = memory + i0
+ ALLOCATE(dely(j0))
+ memory = memory + j0
+ ALLOCATE(delz(k0))
+ memory = memory + k0
+ ALLOCATE(delxa(i0))
+ memory = memory + i0
+ ALLOCATE(delya(j0))
+ memory = memory + j0
+ ALLOCATE(delza(k0))
+ memory = memory + k0
+
+! time periods - dummy -
+ ALLOCATE(bcperiod(ngsmax,3,max(nbctp,1),nsmpl))
+ memory = memory + ngsmax*3*max(nbctp,1)*nsmpl
+ ALLOCATE(ibcperiod(max(nbctp,1)))
+ memory = memory + max(nbctp,1)
+ ALLOCATE(lbcperiod(ngsmax,max(nbctp,1)))
+ memory = memory + ngsmax*max(nbctp,1)
+ ALLOCATE(outt(1))
+ memory = memory + 1
+
+ ALLOCATE(smon_idx(nsmpl))
+ memory = memory + nsmpl
+ CALL set_ival(nsmpl,0,smon_idx)
+
+ ! dummy allocation
+ allocate(delta_time(1))
+ memory = memory + 1
+
+ ALLOCATE(simtime(nsmpl))
+ memory = memory + nsmpl
+
+ allocate(tr_switch(nsmpl))
+ memory = memory + nsmpl
+ do i = 1, nsmpl
+ tr_switch(i) = .true.
+ end do
+
+ ALLOCATE(fh_table(c_fhandler,tlevel_0))
+ memory = memory + c_fhandler*tlevel_0
+
+! reset file handler table
+ CALL omp_new_file_handler(l2,0)
+
+ ALLOCATE(diff_c(max(ntrans,1)))
+ memory = memory + max(ntrans,1)
+ ALLOCATE(mmas_c(max(ntrans,1)))
+ memory = memory + max(ntrans,1)
+ ALLOCATE(beta_c(max(ntrans,1)))
+ memory = memory + max(ntrans,1)
+
+! boundary structures
+ ALLOCATE(ibc_data(max(nbc_data,1),nibc))
+ memory = memory + max(nbc_data,1)*nibc
+ ALLOCATE(dbc_data(max(nbc_data,1),ndbc,nsmpl))
+ memory = memory + max(nbc_data,1)*ndbc*nsmpl
+ ALLOCATE(dbc_dataold(max(nbc_data,1)))
+ memory = memory + max(nbc_data,1)
+
+! borehole logs
+ ALLOCATE(ibh_pos(2,nbh_logs))
+ memory = memory + 2*nbh_logs
+ ALLOCATE(cbh_name(nbh_logs))
+ memory = memory + nbh_logs*64
+
+! - convergency history buffer -
+ ALLOCATE(conv_history(conv_hlen,conv_hmax,nsmpl))
+ memory = memory + conv_hlen*conv_hmax*nsmpl
+ ALLOCATE(conv_chlen(conv_hmax,nsmpl))
+ ALLOCATE(conv_ipos(conv_hmax,nsmpl))
+ ALLOCATE(lcon(conv_hmax,nsmpl))
+ memory = memory + 3*conv_hmax*nsmpl
+
+! OpenMP specific REDUCTION stuff
+ ALLOCATE(omp_dglobal(tlevel_1,9,nsmpl))
+ ALLOCATE(omp_iglobal(tlevel_1,3,nsmpl))
+ memory = memory + 12*tlevel_1*nsmpl
+
+#ifdef BENCH
+ CALL sys_cputime(tend)
+ WRITE(*,'(1A,1F8.2,1A)') &
+ ' [I] : memory allocation time (serial) =', tend - trun, &
+ ' sec'
+ trun = tend
+#endif
+
+! initialisation of this kind, is needfull for NUMA architectures !!!
+! ----------- NUMA -------------
+ DO l2 = 1, nsmpl
+! Tlevel_0 = 1 !!!
+ CALL numa_init(mfactor,l2)
+ END DO
+! ----------- NUMA -------------
+
+#ifdef BENCH
+ CALL sys_cputime(tend)
+ WRITE(*,'(1A,1F8.2,1A)') &
+ ' [I] : memory allocation time (parallel) =', tend - trun, &
+ ' sec'
+#endif
+
+
+ ALLOCATE(sdata(1,nsmpl))
+ memory = memory + nsmpl
+
+ RETURN
+ END SUBROUTINE alloc_arrays
+
+!> @brief initialisation of this kind, is needfull for NUMA architectures !!!
+!> @param[in] mfactor multiply factor for multi-phase methods
+!> @param[in] ismpl local sample index
+ SUBROUTINE numa_init(mfactor,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_data
+ use mod_conc
+ use mod_time
+ use mod_OMP_TOOLS
+ use mod_blocking_size
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k, l
+
+ INCLUDE 'OMP_TOOLS.inc'
+ INTRINSIC dble
+! thread stuff
+ INTEGER tpos, tanz, l2, loc_mem, t_id, mfactor
+
+
+! ----------- NUMA -------------
+!$OMP parallel default(none) private(tpos,tanz,i,j,k,l,l2,loc_mem,t_id)&
+!$OMP num_threads(Tlevel_1)&
+!$OMP shared(a,b,c,d,e,f,g,w,x,head,temp,pres,r,I0,J0,K0)&
+!$OMP shared(ismpl,conc,concold,tsal,ntrans)&
+!$OMP shared(headold,tempold,presold)&
+!$OMP shared(ud,ntrac,Tlevel_1,mfactor)&
+!$OMP shared(lss_bound_block,lss_dnrm,lss_tmp,lss_lUD,lss_lx,lss_lb)&
+!$OMP shared(lss_lMA,lss_lMB,lss_lMC,lss_lMD,lss_lME,lss_lMF,lss_lMG)&
+!$OMP shared(lss_llocTMP,lss_ldnrm,lss_ud_block,lss_lr0_hat)&
+!$OMP shared(max_blocks,block_i,block_j,block_k,bdim_i,bdim_j,bdim_k)
+!$ call omp_binding(ismpl)
+! init
+ t_id = omp_get_his_thread_num() + 1
+ CALL omp_part(i0*j0*k0,tpos,tanz)
+ CALL ijk_m(tpos,i,j,k)
+ loc_mem = max_blocks*block_i*block_j*block_k
+!
+ l2 = (block_i*block_j+block_i*block_k+block_j*block_k)*bdim_i*bdim_j*bdim_k*2
+ CALL set_dval(l2,0.D0,lss_bound_block(1,1,1,1,1,ismpl))
+!
+ CALL set_dval(tanz,0.D0,lss_tmp(tpos,ismpl))
+!
+ CALL set_dval(loc_mem,0.D0,lss_lma(1,t_id,ismpl))
+ CALL set_dval(loc_mem,0.D0,lss_lmb(1,t_id,ismpl))
+ CALL set_dval(loc_mem,0.D0,lss_lmc(1,t_id,ismpl))
+ CALL set_dval(loc_mem,0.D0,lss_lmd(1,t_id,ismpl))
+ CALL set_dval(loc_mem,0.D0,lss_lme(1,t_id,ismpl))
+ CALL set_dval(loc_mem,0.D0,lss_lmf(1,t_id,ismpl))
+ CALL set_dval(loc_mem,0.D0,lss_lmg(1,t_id,ismpl))
+ CALL set_dval(loc_mem,0.D0,lss_lud(1,t_id,ismpl))
+ CALL set_dval(loc_mem,0.D0,lss_lx(1,t_id,ismpl))
+ CALL set_dval(loc_mem,0.D0,lss_lb(1,t_id,ismpl))
+ CALL set_dval(loc_mem*max_loctmp,0.D0,lss_lloctmp(1,1,t_id,ismpl))
+ CALL set_dval(loc_mem,0.D0,lss_ldnrm(1,t_id,ismpl))
+ CALL set_dval(loc_mem,0.D0,lss_lr0_hat(1,t_id,ismpl))
+ l2 = (block_i*block_j+block_i*block_k+block_j*block_k)*max_blocks
+ CALL set_dval(l2,0.D0,lss_ud_block(1,1,t_id,ismpl))
+!
+ DO l = 0, mfactor-1
+ CALL set_dval(tanz,0.D0,lss_dnrm(tpos+l*I0*J0*K0,ismpl))
+ CALL set_dval(tanz,0.D0,a(i,j,k+l*K0,ismpl))
+ CALL set_dval(tanz,0.D0,b(i,j,k+l*K0,ismpl))
+ CALL set_dval(tanz,0.D0,c(i,j,k+l*K0,ismpl))
+ CALL set_dval(tanz,0.D0,d(i,j,k+l*K0,ismpl))
+ CALL set_dval(tanz,0.D0,e(i,j,k+l*K0,ismpl))
+ CALL set_dval(tanz,0.D0,f(i,j,k+l*K0,ismpl))
+ CALL set_dval(tanz,0.D0,g(i,j,k+l*K0,ismpl))
+ CALL set_dval(tanz,0.D0,w(i,j,k+l*K0,ismpl))
+ CALL set_dval(tanz,0.D0,x(i,j,k+l*K0,ismpl))
+ CALL set_dval(tanz,0.D0,ud(i,j,k+l*K0,ismpl))
+ END DO
+!
+ CALL set_dval(tanz,0.D0,head(i,j,k,ismpl))
+ CALL set_dval(tanz,10.0D0,temp(i,j,k,ismpl))
+ CALL set_dval(tanz,0.D0,pres(i,j,k,ismpl))
+ DO l = 1, max(ntrans,1)
+ CALL set_dval(tanz,0.D0,conc(i,j,k,l,ismpl))
+ END DO
+ CALL set_dval(tanz,0.D0,tsal(i,j,k,ismpl))
+
+ DO l = 1, ncgen
+ CALL set_dval(tanz,100.0D0,headold(tpos,l,ismpl))
+ END DO
+ DO l = 1, ncgen
+ CALL set_dval(tanz,20.0D0,tempold(tpos,l,ismpl))
+ END DO
+ DO l = 1, ncgen
+ CALL set_dval(tanz,1.5D7,presold(tpos,l,ismpl))
+ END DO
+ DO l = 1, ncgen
+ DO l2 = 1, max(ntrans,1)
+ CALL set_dval(tanz,0.D0,concold(tpos,l2,l,ismpl))
+ END DO
+ END DO
+! independent of nsmpl
+ IF (ismpl==1) THEN
+! [flow,temp,conc*]
+ DO l = 1, mfactor
+ CALL set_dval(tanz,0.D0,r(i,j,k+(l-1)*k0))
+ END DO
+!$OMP barrier
+!$OMP do
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+! random vector needed for BiCGStab lineare solver
+! later can be initialised from a real random-number-generator
+ r(i,j,k) = 1.0D3/dble(0.25D0+i0/2-i+j0/2-j+k0/2-k)
+! [flow,temp,conc*], [pres]
+ DO l = 2, mfactor
+ r(i,j,k+(l-1)*k0) = r(i,j,k+(l-2)*k0)*0.1D0
+ END DO
+ END DO
+ END DO
+ END DO
+!$OMP end do
+ END IF
+!$OMP end parallel
+! ----------- NUMA -------------
+ RETURN
+ END SUBROUTINE numa_init
diff --git a/forward/alloc_data.f90 b/forward/alloc_data.f90
new file mode 100644
index 0000000..5fd52cd
--- /dev/null
+++ b/forward/alloc_data.f90
@@ -0,0 +1,87 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief allocate data arrays (dynamic size)
+!> @param[in] ismpl local sample index
+!> @details
+ SUBROUTINE alloc_data(ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_data
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ INTRINSIC max
+
+ IF (linfos(1)>=2) THEN
+ WRITE(*,*) ' '
+ WRITE(*,*) ' [I] : ... alloc_data'
+ WRITE(*,*) ' '
+ END IF
+!
+ IF (ndata>=1) THEN
+ ALLOCATE(ddata(ndata,n_ddata))
+ memory = memory + ndata*n_ddata
+ ALLOCATE(idata(ndata,n_idata))
+ memory = memory + ndata*n_idata
+ END IF
+!
+ DEALLOCATE(sdata)
+ memory = memory - nsmpl
+ ALLOCATE(sdata(max(ndata,1),nsmpl))
+ memory = memory + max(ndata,1)*nsmpl
+!
+ RETURN
+ END SUBROUTINE alloc_data
+
+
+!> @brief free data arrays (with dynamic size)
+!> @param[in] ismpl local sample index
+!> @details
+ SUBROUTINE dealloc_data(ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_data
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ INTRINSIC max
+
+ IF (linfos(1)>=2) THEN
+ WRITE(*,*) ' '
+ WRITE(*,*) ' [I] : ... dealloc_data'
+ WRITE(*,*) ' '
+ END IF
+!
+ IF (ndata>=1) THEN
+ DEALLOCATE(ddata)
+ memory = memory - ndata*n_ddata
+ DEALLOCATE(idata)
+ memory = memory - ndata*n_idata
+ END IF
+ DEALLOCATE(sdata)
+ memory = memory - max(ndata,1)*nsmpl
+!
+ RETURN
+ END SUBROUTINE dealloc_data
diff --git a/forward/arrays.f90 b/forward/arrays.f90
new file mode 100644
index 0000000..7838fdf
--- /dev/null
+++ b/forward/arrays.f90
@@ -0,0 +1,738 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief declaration of all main variables, arrays and constants
+!> @details
+!> definition of global (dynamic) arrays, constants and main descriptions\n
+ MODULE arrays
+ IMPLICIT NONE
+
+ !> @brief Numerical precision and min/max value.
+ !> @details
+ !> Numerical precision and min/max value. \n\n
+ !> (1) last digit precision \n
+ !> (2) min allowed dble value \n
+ !> (3) max allowed dble value \n
+ double precision, dimension (3) :: const_dble
+
+ !> @brief Project suffix, filename extension.
+ !> @details
+ !> Project suffix, filename extension. \n\n
+ !> project name extension/suffix\n
+ !> Size: nsmpl.
+ character (len=80), allocatable, dimension (:) :: project_sfx
+
+ ! Size of grid
+ ! ------------
+
+ !> @brief Cell dimension array, x-direction.
+ !> @details
+ !> Cell dimension array, x-direction. \n\n
+ !> delta size of cell, size i0.
+ double precision, allocatable, dimension (:) :: delx
+
+ !> @brief Cell dimension array, y-direction.
+ !> @details
+ !> Cell dimension array, y-direction. \n\n
+ !> delta size of cell, size j0.
+ double precision, allocatable, dimension (:) :: dely
+
+ !> @brief Cell dimension array, z-direction.
+ !> @details
+ !> Cell dimension array, z-direction. \n\n
+ !> delta size of cell, size k0.
+ double precision, allocatable, dimension (:) :: delz
+
+ !> @brief Absolute cell center positions, x-direction.
+ !> @details
+ !> Absolute cell center positions, x-direction. \n\n
+ !> absolute position, size i0.\n\n
+ !> With reference to the left, front, bottom corner of the
+ !> model.
+ double precision, allocatable, dimension (:) :: delxa
+
+ !> @brief Absolute cell center positions, y-direction.
+ !> @details
+ !> Absolute cell center positions, y-direction. \n\n
+ !> absolute position, size j0.\n\n
+ !> With reference to the left, front, bottom corner of the
+ !> model.
+ double precision, allocatable, dimension (:) :: delya
+
+ !> @brief Absolute cell center positions, z-direction.
+ !> @details
+ !> Absolute cell center positions, z-direction. \n\n
+ !> absolute position, size k0.\n\n
+ !> With reference to the left, front, bottom corner of the
+ !> model.
+ double precision, allocatable, dimension (:) :: delza
+
+ ! Variable arrays
+ ! ---------------
+
+ !> @brief Variable array hydraulic potential.
+ !> @details
+ !> Variable array hydraulic potential. \n\n
+ !> Indices: \n
+ !> 1. i-index \n
+ !> 2. j-index \n
+ !> 3. k-index \n
+ !> 4. sample index \n
+ double precision, allocatable, dimension (:,:,:,:) :: head
+
+ !> @brief Variable array pressure.
+ !> @details
+ !> Variable array pressure. \n\n
+ !> Indices: \n
+ !> 1. i-index \n
+ !> 2. j-index \n
+ !> 3. k-index \n
+ !> 4. sample index \n
+ double precision, allocatable, dimension (:,:,:,:) :: pres
+
+ !> @brief Variable array temperature.
+ !> @details
+ !> Variable array temperature. \n\n
+ !> Indices: \n
+ !> 1. i-index \n
+ !> 2. j-index \n
+ !> 3. k-index \n
+ !> 4. sample index \n
+ double precision, allocatable, dimension (:,:,:,:) :: temp
+
+ !> @brief Variable array concentrations.
+ !> @details
+ !> Variable array concentrations. \n\n
+ !> Indices: \n
+ !> 1. i-index \n
+ !> 2. j-index \n
+ !> 3. k-index \n
+ !> 4. species index \n
+ !> 5. sample index \n
+ double precision, allocatable, dimension (:,:,:,:,:) :: conc
+
+ !> @brief Array of concentration iteration differences.
+ !> @details
+ !> Array of concentration iteration differences. \n\n
+ !> Used for checking concentration convergence.
+ double precision, allocatable, dimension (:,:) :: conc_conv
+
+ !> @brief Array of total salinities.
+ !> @details
+ !> Array of total salinities. \n\n
+ !> Indices: \n
+ !> 1. i-index \n
+ !> 2. j-index \n
+ !> 3. k-index \n
+ !> 4. sample index \n
+ double precision, allocatable, dimension (:,:,:,:) :: tsal
+
+ ! Variables for variable time stepping
+ ! ------------------------------------
+
+ !> @brief Array with flag for nonlinear iteration maxout.
+ !> @details
+ !> Array with flag for nonlinear iteration maxout. \n\n
+ !>
+ !> - "0": Initialized value \n
+ !> - "1": Nonlinear iteration fine, possibly double time
+ !> step. \n
+ !> - "-2": Iterative solver or Picard/Newton iteration reached
+ !> maxiter. Half time step. \n
+ !>
+ !> Variable for variable time stepping.
+ integer, allocatable, dimension (:) :: flag_delt
+
+ !> @brief Array with counters for doubling time step.
+ !> @details
+ !> Array with counters for doubling time step. \n
+ !>
+ !> Variable for variable time stepping.
+ integer, allocatable, dimension (:) :: delt_count
+
+ !> @brief Array containing information if it is the first timestep.
+ !> @details
+ !> Array containing information if it is the first timestep. \n
+ !> - 0: First time step \n
+ !> - 1: Not the first time step. \n\n
+ !>
+ !> The information is carried for each sample, the length will
+ !> be nsmpl. \n\n
+ !>
+ !> Variable for variable time stepping.
+ integer, allocatable :: flag_1st_timestep(:)
+
+ !> @brief Array of previous time step lengths for variable time step.
+ !> @details
+ !> Array of previous time step lengths for variable time step. \n\n
+ !>
+ !> Variable for variable time stepping.
+ double precision, allocatable, dimension (:) :: delt_old
+
+! maximum of the used units/BC-units ("maxunits"/"bc_maxunits")
+ INTEGER nunits
+! number of rock properties + boundary condition types, number of regular rock properties (to load)
+ INTEGER nprop, nprop_load
+! first/last index of normal properties in 'nprop'
+ INTEGER maxunits, firstidx, lastidx
+! first/last index of bc-units in 'nprop'
+ INTEGER bc_maxunits, bc_firstidx, bc_lastidx, nbc
+
+! string constants for the number of property-units and bc-units
+ character (len=2) :: c_npropunit, c_nbcunit, c_npv
+
+ PARAMETER (firstidx=1) ! first rock properties
+ PARAMETER (lastidx=17) ! last rock properties
+ PARAMETER (bc_firstidx=18) ! first BC unit
+ PARAMETER (bc_lastidx=22) ! last BC unit
+ PARAMETER (nbc=bc_lastidx-bc_firstidx+1)
+ PARAMETER (nprop=lastidx-firstidx+1 +bc_lastidx-bc_firstidx+1)
+! load fewer, except 3*bc-units
+ PARAMETER (nprop_load=nprop-nbc)
+
+! unit index number, unit-cell assignment (rock property for each cell)
+ INTEGER, ALLOCATABLE :: uindex(:,:,:)
+! cell index number, no assignment - only for output (grouping)
+ INTEGER, ALLOCATABLE :: cindex(:,:,:)
+
+! def_props = '<name>'
+ DOUBLE PRECISION, ALLOCATABLE :: propunit(:,:,:)
+
+! disable additional hdf5-output
+ INTEGER nout_ijk
+ PARAMETER (nout_ijk=9)
+ LOGICAL out_ijk(nout_ijk)
+ INTEGER cout_i, cout_j, cout_k
+ PARAMETER (cout_i=1)
+ PARAMETER (cout_j=2)
+ PARAMETER (cout_k=3)
+ INTEGER cout_vx, cout_vy, cout_vz
+ PARAMETER (cout_vx=4)
+ PARAMETER (cout_vy=5)
+ PARAMETER (cout_vz=6)
+ INTEGER cout_rhof, cout_visf, cout_uindex
+ PARAMETER (cout_rhof=7)
+ PARAMETER (cout_visf=8)
+ PARAMETER (cout_uindex=9)
+
+ INTEGER ncompress
+ PARAMETER (ncompress=4)
+ character (len=5) :: compress_suffix(ncompress)
+ DATA compress_suffix/'plain', 'bz2', 'gz', 'zip'/
+ LOGICAL out_prop(nprop)
+ character (len=4) :: properties(nprop+2)
+ DATA properties/' por', 'a_kx', 'a_ky', ' kz', 'comp', &
+ 'a_lx', 'a_ly', ' lz', ' q', ' rc', ' df', ' ec', &
+ ' lc', ' bcl', 'bcpd', 's_nr', 's_wr', &
+ ' hbc', ' tbc', ' cbc', ' ebc', 'snbc', ' tp', ' sbc'/
+ character (len=80) :: doc_properties(nprop+2)
+ DATA doc_properties/'porosity', &
+ 'permeability, anisotropic direction X (ratio of Z), default 1.0', &
+ 'permeability, anisotropic direction Y (ratio of Z), default 1.0', &
+ 'permeability, direction Z', &
+ 'compressibility of rock, default 1.0e-10', &
+ 'conductivity, anisotropic direction X (ratio of Z), default 1.0', &
+ 'conductivity, anisotropic direction Y (ratio of Z), default 1.0', &
+ 'conductivity, direction Z', &
+ 'heat production, default 0.0', &
+ 'heat capacity of rock, default 2.06e6', &
+ 'diffusivity, default 10.0', &
+ 'electrical conductivity, default 0.0', &
+ 'coupling coefficient, default 0.0', &
+ 'Brooks Corey "lambda" - pore size distribution index, default 2.0', &
+ 'Brooks Corey displacement pressure (PD), default 1.0d6', &
+ 'residual saturation of the non-wetting phase, default 0.05', &
+ 'residual saturation of the wetting phase, default 0.2', &
+ 'flow boundary condition', &
+ 'temperature boundary condition', &
+ 'concentration boundary condition', &
+ 'electric potential boundary condition', &
+ 'saturation (non-wetting) boundary condition', &
+ 'time periods', &
+ 'unspecified single cell boundary condition'/
+ DOUBLE PRECISION prop_max(nprop_load)
+ DATA prop_max/1.0D0, 1.0D+30, 1.0D+30, 1.0D+30, 1.0D+50, &
+ 1.0D+30, 1.0D+30, 1.0D+30, 1.0D+30, 1.0D+30, 1.0D+30, 1.0D+30, &
+ 1.0D+50, 10.0d0, 1.0D+30, 1.0D0, 1.0D0/
+ DOUBLE PRECISION prop_min(nprop_load)
+ DATA prop_min/1.0D-30, 1.0D-3, 1.0D-3, 1.0D-30, 1.0D-50, &
+ 1.0D-3, 1.0D-3, 1.0D-3, 1.0D-20, 1.0D-10, 0.0D0, 1.0D-10, &
+ 1.0D-50, 1.0D-2, 0.0D0, 0.0D0, 0.0D0/
+ DOUBLE PRECISION prop_default(nprop_load)
+ DATA prop_default/1.0D-7, 1.0D0, 1.0D0, 1.0D-20, 1.0D-10, &
+ 1.0D0, 1.0D0, 2.0D0, 0.0D0, 2.0D6, 10.0D0, 0.0D0, &
+ 0.0D0, 2.0D0, 1.0D3, 0.05D0, 0.2D0/
+
+! ------------------------------------------
+ INTEGER idx_por
+ INTEGER idx_an_kx
+ INTEGER idx_an_ky
+ INTEGER idx_kz
+ INTEGER idx_comp
+ INTEGER idx_an_lx
+ INTEGER idx_an_ly
+ INTEGER idx_lz
+ INTEGER idx_q
+ INTEGER idx_rc
+ INTEGER idx_df
+ INTEGER idx_ec
+ INTEGER idx_lc
+
+
+ INTEGER idx_s_nr
+ INTEGER idx_s_wr
+ INTEGER idx_hbc
+ INTEGER idx_tbc
+ INTEGER idx_cbc
+ INTEGER idx_ebc
+ INTEGER idx_snbc
+! integer idx_pbc
+
+ PARAMETER (idx_por=1)
+ PARAMETER (idx_an_kx=2)
+ PARAMETER (idx_an_ky=3)
+ PARAMETER (idx_kz=4)
+ PARAMETER (idx_comp=5)
+ PARAMETER (idx_an_lx=6)
+ PARAMETER (idx_an_ly=7)
+ PARAMETER (idx_lz=8)
+ PARAMETER (idx_q=9)
+ PARAMETER (idx_rc=10)
+ PARAMETER (idx_df=11)
+ PARAMETER (idx_ec=12)
+ PARAMETER (idx_lc=13)
+
+
+ PARAMETER (idx_s_nr=16)
+ PARAMETER (idx_s_wr=17)
+ PARAMETER (idx_hbc=18)
+ PARAMETER (idx_tbc=19)
+ PARAMETER (idx_cbc=20)
+ PARAMETER (idx_ebc=21)
+ PARAMETER (idx_snbc=22)
+! parameter (idx_pbc = 18)?? like idx_hbc
+! ------------------------------------------
+ INTEGER idx_tp
+ INTEGER idx_sbc
+ PARAMETER (idx_tp=nprop+1)
+ PARAMETER (idx_sbc=nprop+2)
+! ------------------------------------------
+
+! new boundary-condition structures
+! i,j,k - position
+ INTEGER cbc_i, cbc_j, cbc_k
+ PARAMETER (cbc_i=1)
+ PARAMETER (cbc_j=2)
+ PARAMETER (cbc_k=3)
+! bc-unit, bc time dependend
+ INTEGER cbc_bcu, cbc_bctp
+ PARAMETER (cbc_bcu=4)
+ PARAMETER (cbc_bctp=5)
+! physical value, boundary type (neuman, dirichlet), sub index (species)
+ INTEGER cbc_pv, cbc_bt, cbc_si, cbc_dir
+ PARAMETER (cbc_pv=6)
+ PARAMETER (cbc_bt=7)
+ PARAMETER (cbc_si=8)
+ PARAMETER (cbc_dir=9)
+! bc-type max index
+ INTEGER nibc, ndbc
+ PARAMETER (nibc=9)
+! 1:value, 2:bcmy, 3:additional value (e.g. for well function pressure)
+ PARAMETER (ndbc=3)
+
+ ! Physical value (pv) indices and names
+ ! -------------------------------------
+
+ !> @brief Physical value index: head.
+ !> @details
+ !> Physical value index: head. \n\n
+ integer, parameter :: pv_head = 1
+
+ !> @brief Physical value index: temp.
+ !> @details
+ !> Physical value index: temp. \n\n
+ integer, parameter :: pv_temp = 2
+
+ !> @brief Physical value index: conc.
+ !> @details
+ !> Physical value index: conc. \n\n
+ integer, parameter :: pv_conc = 3
+
+ !> @brief Physical value index: pres.
+ !> @details
+ !> Physical value index: pres. \n\n
+ integer, parameter :: pv_pres = 5
+
+ !> @brief Physical value index: bhpr.
+ !> @details
+ !> Physical value index: bhpr. \n\n
+ !> Special case for borehole output.
+ integer, parameter :: pv_bhpr = 6
+
+ !> @brief Number of physical value indices.
+ !> @details
+ !> Number of physical value indices. \n\n
+ !> Or: pv max index.
+ integer, parameter :: npv = 6
+
+ !> @brief Array of physical value names.
+ !> @details
+ !> Array of physical value names. \n\n
+ character (len=4), parameter, dimension (npv) :: pv_name = &
+ (/'head', 'temp', 'conc', 'nova', 'pres', 'bhpr'/)
+
+ !> @brief Array of physical value output switches.
+ !> @details
+ !> Array of physical output switches. \n\n
+ !> Switches are set according to activity of variables. Output
+ !> (vtk/hdf5) for specific variables can be suppressed by
+ !> specifying the physical value name in `# disable output`.
+ logical out_pv(npv)
+
+! bc-type
+ INTEGER bt_diri, bt_neum, bt_neuw
+ PARAMETER (bt_diri=1)
+ PARAMETER (bt_neum=2)
+ PARAMETER (bt_neuw=3)
+ character (len=3) :: bc_name(3)
+ DATA bc_name/'bcd', 'bcn', 'bcw'/
+! boundary-condition structures
+ INTEGER, ALLOCATABLE :: ibc_data(:,:)
+ DOUBLE PRECISION, ALLOCATABLE :: dbc_data(:,:,:)
+ DOUBLE PRECISION, ALLOCATABLE :: dbc_dataold(:)
+
+! borehole logs
+ INTEGER nbh_logs
+ INTEGER, ALLOCATABLE :: ibh_pos(:,:)
+ character (len=256), dimension (:), allocatable :: cbh_name
+
+! Begin and End of the pv-blocks after sorting
+! reuse *_flow for head and pres !!!
+ INTEGER first_flow, last_flow
+ INTEGER first_temp, last_temp
+ INTEGER first_conc, last_conc
+ INTEGER nbc_data
+
+ ! Observed data
+ ! -------------
+
+ !> @brief Array of integer data specifications.
+ !> @details
+ !> Array of integer data specifications. \n
+ !> Index 2: [i,j,k, type, sub-index, obs]
+ integer, allocatable, dimension (:,:) :: idata
+
+ !> @brief Array of double precision data specifications.
+ !> @details
+ !> Array of double precision data specifications. \n
+ !> Index2: [value, weighting, time, px,py,pz]
+ double precision, allocatable, dimension (:,:) :: ddata
+
+ !> @brief Array of simulated data values.
+ !> @details
+ !> Array of simulated data values. \n
+ !> Save the computed values to compare it with
+ !> 'ddata(:,cid_pv)' \n
+ !> Index 2: Sample index.
+ double precision, allocatable, dimension (:,:) :: sdata
+
+ !> @brief Index position in idata for i.
+ !> @details
+ !> Index position in idata for i. \n
+ integer, parameter :: cid_i = 1
+
+ !> @brief Index position in idata for j.
+ !> @details
+ !> Index position in idata for j. \n
+ integer, parameter :: cid_j = 2
+
+ !> @brief Index position in idata for k.
+ !> @details
+ !> Index position in idata for k. \n
+ integer, parameter :: cid_k = 3
+
+ !> @brief Index position in idata for type.
+ !> @details
+ !> Index position in idata for type. \n
+ integer, parameter :: cid_pv = 4
+
+ !> @brief Index position in idata for sub-index.
+ !> @details
+ !> Index position in idata for sub-index. \n
+ integer, parameter :: cid_si = 5
+
+ !> @brief Index position in idata for obs.
+ !> @details
+ !> Index position in idata for obs. \n
+ integer, parameter :: cid_obs = 6
+
+ !> @brief Index-2 dimension of idata.
+ !> @details
+ !> Index-2 dimension of idata. \n
+ !> Number of different integer-parameters arrays in idata.
+ integer, parameter :: n_idata = 6
+
+ !> @brief Index position in ddata for value.
+ !> @details
+ !> Index position in ddata for value. \n
+ integer, parameter :: cdd_pv = 1
+
+ !> @brief Index position in ddata for weighting.
+ !> @details
+ !> Index position in ddata for weighting. \n
+ integer, parameter :: cdd_w = 2
+
+ !> @brief Index position in ddata for time.
+ !> @details
+ !> Index position in ddata for time. \n
+ integer, parameter :: cdd_time = 3
+
+ !> @brief Index position in ddata for px.
+ !> @details
+ !> Index position in ddata for px. \n
+ integer, parameter :: cdd_i = 4
+
+ !> @brief Index position in ddata for py.
+ !> @details
+ !> Index position in ddata for py. \n
+ integer, parameter :: cdd_j = 5
+
+ !> @brief Index position in ddata for pz.
+ !> @details
+ !> Index position in ddata for pz. \n
+ integer, parameter :: cdd_k = 6
+
+ !> @brief Index-2 dimension of ddata.
+ !> @details
+ !> Index-2 dimension of ddata. \n
+ !> Number of different double-precision-parameters arrays in
+ !> ddata.
+ integer, parameter :: n_ddata = 6
+
+! jump table between parameter index and seeding
+ INTEGER, ALLOCATABLE :: seed_para(:,:)
+ INTEGER, ALLOCATABLE :: gpara(:)
+
+ ! Coefficients for linear system solver
+ ! -------------------------------------
+
+ !> @brief Linear system solver coefficent array a.
+ !> @details
+ !> Linear system solver coefficent array a. \n
+ DOUBLE PRECISION, ALLOCATABLE :: a(:,:,:,:)
+
+ !> @brief Linear system solver coefficent array b.
+ !> @details
+ !> Linear system solver coefficent array b. \n
+ DOUBLE PRECISION, ALLOCATABLE :: b(:,:,:,:)
+
+ !> @brief Linear system solver coefficent array c.
+ !> @details
+ !> Linear system solver coefficent array c. \n
+ DOUBLE PRECISION, ALLOCATABLE :: c(:,:,:,:)
+
+ !> @brief Linear system solver coefficent array d.
+ !> @details
+ !> Linear system solver coefficent array d. \n
+ DOUBLE PRECISION, ALLOCATABLE :: d(:,:,:,:)
+
+ !> @brief Linear system solver coefficent array e.
+ !> @details
+ !> Linear system solver coefficent array e. \n
+ DOUBLE PRECISION, ALLOCATABLE :: e(:,:,:,:)
+
+ !> @brief Linear system solver coefficent array f.
+ !> @details
+ !> Linear system solver coefficent array f. \n
+ DOUBLE PRECISION, ALLOCATABLE :: f(:,:,:,:)
+
+ !> @brief Linear system solver coefficent array g.
+ !> @details
+ !> Linear system solver coefficent array g. \n
+ DOUBLE PRECISION, ALLOCATABLE :: g(:,:,:,:)
+
+ !> @brief Linear system solver coefficent array w.
+ !> @details
+ !> Linear system solver coefficent array w. \n
+ DOUBLE PRECISION, ALLOCATABLE :: w(:,:,:,:)
+
+ !> @brief Linear system solver coefficent array x.
+ !> @details
+ !> Linear system solver coefficent array x. \n
+ DOUBLE PRECISION, ALLOCATABLE :: x(:,:,:,:)
+
+! [r0] random number vector, used for BiCGStab algorithm
+ DOUBLE PRECISION, ALLOCATABLE :: r(:,:,:)
+! openmp-private/locale vectors for linear system solver (lss_*)
+! team-global buffer for boundary exchange (+ismpl)
+ DOUBLE PRECISION, ALLOCATABLE :: lss_bound_block(:,:,:,:,:,:)
+ DOUBLE PRECISION, ALLOCATABLE :: lss_dnrm(:,:)
+ DOUBLE PRECISION, ALLOCATABLE :: lss_tmp(:,:)
+! private copy for preconditioning (+Tlevel_1 +ismpl)
+ DOUBLE PRECISION, ALLOCATABLE :: lss_lma(:,:,:), lss_lmb(:,:,:)
+ DOUBLE PRECISION, ALLOCATABLE :: lss_lmc(:,:,:), lss_lmd(:,:,:)
+ DOUBLE PRECISION, ALLOCATABLE :: lss_lme(:,:,:), lss_lmf(:,:,:)
+ DOUBLE PRECISION, ALLOCATABLE :: lss_lmg(:,:,:), lss_lud(:,:,:)
+ DOUBLE PRECISION, ALLOCATABLE :: lss_lx(:,:,:), lss_lb(:,:,:)
+ DOUBLE PRECISION, ALLOCATABLE :: lss_lloctmp(:,:,:,:)
+ DOUBLE PRECISION, ALLOCATABLE :: lss_ldnrm(:,:,:)
+ DOUBLE PRECISION, ALLOCATABLE :: lss_ud_block(:,:,:,:)
+ DOUBLE PRECISION, ALLOCATABLE :: lss_lr0_hat(:,:,:)
+
+! for ilu-precond. (shadow vectors)
+ DOUBLE PRECISION, ALLOCATABLE :: ud(:,:,:,:)
+! marker of current boundary conditions elements
+ CHARACTER, ALLOCATABLE :: bc_mask(:,:)
+
+! boundary condition info, values 'n','d',' ' on positions [head,temp,conc,pres]
+ character (len=npv), dimension (:,:,:), allocatable :: node_info
+
+! spez. ILU arrays
+! proc. index of block
+ INTEGER, ALLOCATABLE :: proza(:,:,:)
+
+ !> @brief Array for storing old head for iteration.
+ !> @details
+ !> Array for storing old head for iteration. \n\n
+ !> Indices: \n
+ !> 1. linear cell-index \n
+ !> 2. cgen-level index \n
+ !> 3. sample index\n
+ !> Size: [I0*J0*K0,ncgen,nsmpl], used for forward newton iteration
+ double precision, allocatable, dimension (:,:,:) :: headold
+
+ !> @brief Array for storing old temp for iteration.
+ !> @details
+ !> Array for storing old temp for iteration. \n\n
+ !> Indices: \n
+ !> 1. linear cell-index \n
+ !> 2. cgen-level index \n
+ !> 3. sample index\n
+ !> Size: [I0*J0*K0,ncgen,nsmpl], used for forward newton iteration
+ double precision, allocatable, dimension (:,:,:) :: tempold
+
+ !> @brief Array for storing old pressure for iteration.
+ !> @details
+ !> Array for storing old pressure for iteration. \n\n
+ !> Indices: \n
+ !> 1. linear cell-index \n
+ !> 2. cgen-level index \n
+ !> 3. sample index\n
+ !> Size: [I0*J0*K0,ncgen,nsmpl], used for forward newton iteration
+ double precision, allocatable, dimension (:,:,:) :: presold
+
+ !> @brief Array for storing old conc for iteration.
+ !> @details
+ !> Array for storing old conc for iteration. \n\n
+ !> Indices: \n
+ !> 1. linear cell-index \n
+ !> 2. species index \n
+ !> 3. cgen-level index \n
+ !> 4. sample index\n
+ !> Size: [I0*J0*K0,max(ntrans,1),ncgen,nsmpl], used for forward newton iteration
+ double precision, allocatable, dimension (:,:,:,:) :: concold
+
+! BC time period: (period-index,value-type,TP-ID,sample)
+! - value-type: time, BC-value
+ DOUBLE PRECISION, ALLOCATABLE :: bcperiod(:,:,:,:)
+! BC time period - number of periods: (TP-ID)
+ INTEGER, ALLOCATABLE :: ibcperiod(:)
+! BC time period - on/off-switch: (period-index,TP-ID)
+ LOGICAL, ALLOCATABLE :: lbcperiod(:,:)
+
+ !> @brief Array of output times.
+ !> @details
+ !> Array of output times. \n
+ !> Define output times (time dependend) \n
+ !> Read under `# output times`. \n
+ double precision, allocatable, dimension (:) :: outt
+
+! define monitor index, used for "simulate"
+ INTEGER, ALLOCATABLE :: smon_idx(:)
+
+ !> @brief Array of time step durations/lengths/values.
+ !> @details
+ !> Array of time step durations/lengths/values. \n
+ !> The time step lengths are computed in `calc_deltatime`
+ !> according to the input under `# time periods`: \n
+ !> - start and end times of the time periods \n
+ !> - number of time steps per period \n
+ !> - step type (f.e. distributed linearly, logarithmically) \n
+ double precision, allocatable, dimension (:) :: delta_time
+
+ !> @brief Simulation time
+ !> @details
+ !> Simulation time. \n
+ !> Simulation time for each sample are set in
+ !> `forward/forward_iter.f90`.
+ double precision, allocatable, dimension (:) :: simtime
+
+ !> @brief Samples array for transient switches
+ !> @details
+ !> Samples array for transient switches. \n\n
+ !>
+ !> transient execption, to toggle it off
+ logical, allocatable, dimension (:) :: tr_switch
+
+ INTEGER c_fhandler, c_foffset
+! [max # of files per thread]
+ PARAMETER (c_fhandler=100)
+! file-handler offset
+ PARAMETER (c_foffset=30)
+! file handler table
+ INTEGER, ALLOCATABLE :: fh_table(:,:)
+
+! - convergency history buffer -
+! max history length
+ INTEGER conv_hlen
+ PARAMETER (conv_hlen=50)
+! number of histories
+ INTEGER conv_hmax
+! history buffer
+ DOUBLE PRECISION, ALLOCATABLE :: conv_history(:,:,:)
+! current history length
+ INTEGER, ALLOCATABLE :: conv_chlen(:,:)
+! current position index
+ INTEGER, ALLOCATABLE :: conv_ipos(:,:)
+! convergency, when this vector is true
+ LOGICAL, ALLOCATABLE :: lcon(:,:)
+
+! default flow values from read_model.f90
+ DOUBLE PRECISION, ALLOCATABLE :: vdefault(:,:)
+ LOGICAL :: vdefaultswitch
+
+! transport
+ DOUBLE PRECISION, ALLOCATABLE :: mmas_c(:)
+ DOUBLE PRECISION, ALLOCATABLE :: diff_c(:)
+ DOUBLE PRECISION, ALLOCATABLE :: beta_c(:)
+
+
+! OpenMP REDUCTION arrays
+ DOUBLE PRECISION, ALLOCATABLE :: omp_dglobal(:,:,:)
+ INTEGER, ALLOCATABLE :: omp_iglobal(:,:,:)
+
+!---- only for DEBUG !!! ----
+ INTEGER n_debugout
+! [2,n_debugout]: 1: time step, 2: nl iteration
+ INTEGER, ALLOCATABLE :: debugout(:,:)
+
+ END MODULE arrays
diff --git a/forward/bhpr.f90 b/forward/bhpr.f90
new file mode 100644
index 0000000..dd5a7e1
--- /dev/null
+++ b/forward/bhpr.f90
@@ -0,0 +1,149 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculate well pressure according to Shu,2005
+!> @param[in] ismpl local sample index
+!> @param[in] ii i cell-index
+!> @param[in] jj i cell-index
+!> @param[in] kk i cell-index
+!> @details
+!> Reference: J. Shu\n COMPARISON OF VARIOUS TECHINQUES FOR COMPUTING
+!> WELL INDEX\n Master Thesis, Stanford 2005\n\n
+!>
+!> modify coefficents for the head equation according to the boundary
+!> conditions, coefficients are stored as vectors in the diagonals a-g
+!> (d center), and rhs in w.\n
+ DOUBLE PRECISION FUNCTION bhpr(ii,jj,kk,ismpl)
+
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_temp
+ use mod_flow
+ use mod_time
+ use mod_linfos
+
+ IMPLICIT NONE
+
+ integer :: ismpl
+ integer :: i, j, k
+ integer :: ib
+!
+ INTEGER ii, jj, kk, bcu, tpbcu, bctype, i_dir
+ DOUBLE PRECISION val, malfa, mbeta
+ DOUBLE PRECISION d_x,d_y,d_z,k_x,k_y,k_z,wi_x,wi_y,wi_z,wi_pj
+ ! DOUBLE PRECISION l_x,l_y
+ DOUBLE PRECISION l_z
+ DOUBLE PRECISION r_b,r_w,skin
+ ! DOUBLE PRECISION xz,zx,yz,zy
+ DOUBLE PRECISION xy,yx
+ DOUBLE PRECISION kx,ky,kz,visf
+!
+ PARAMETER (skin=0.d0,r_w=0.15)
+!
+ EXTERNAL kx,ky,kz,visf
+ INTRINSIC max
+
+
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! dirichlet nodes - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! neumann nodes - - - - - - - - - - - - - - - - - - - - - - - - - -
+!
+ ! default well pressure
+ bhpr = 0.0d0
+
+ DO ib = first_flow, last_flow
+
+ i = ibc_data(ib,cbc_i)
+ j = ibc_data(ib,cbc_j)
+ k = ibc_data(ib,cbc_k)
+ bctype = ibc_data(ib,cbc_bt)
+
+ ! neumann bc?, skip otherwise
+ ! data point? skip otherwise
+ IF (ii==i.AND.jj==j .AND. kk==k .AND. bctype==bt_neuw) THEN
+
+ bcu = ibc_data(ib,cbc_bcu)
+ tpbcu = max(ibc_data(ib,cbc_bctp),0)
+ i_dir = ibc_data(ib,cbc_dir)
+
+ ! WELLMODEL
+ ! discrete values
+ val = dbc_data(ib,1,ismpl)
+
+ IF ((tpbcu>0) .AND. nbctp>0) THEN
+
+ ! time-dependent bc: val=ac*val+bc
+ ! get Alfa and Beta modificators
+ CALL get_tpbcalbe(malfa,mbeta,tpbcu,ismpl)
+
+ ! update time dependend modification of the bc-value
+ val = malfa + mbeta*val
+
+ END IF
+!
+ IF (tpbcu>=0) THEN
+
+ k_x = kx(i,j,k,ismpl)
+ k_y = ky(i,j,k,ismpl)
+ k_z = kz(i,j,k,ismpl)
+
+ d_x = delx(i)
+ d_y = dely(j)
+ d_z = delz(k)
+
+! l_x=0.d0
+! yz=k_y/k_z
+! zy=k_z/k_y
+! r_b=0.28d0*sqrt((sqrt(yz)*d_z**2+sqrt(zy)*d_y**2))/ &
+! (yz**0.25+zy**0.25)
+! wi_x = 2.0d0*pi*sqrt(k_y*k_z)*l_x/(log(r_b/r_w)+skin)
+ wi_x = 0.0d0
+
+! l_y=0.d0
+! xz=k_x/k_z
+! zx=k_z/k_x
+! r_b=0.28d0*sqrt((sqrt(xz)*d_z**2+sqrt(zx)*d_x**2))/ &
+! (xz**0.25+zx**0.25)
+! wi_y = 2.0d0*pi*sqrt(k_x*k_z)*l_y/(log(r_b/r_w)+skin)
+ wi_y = 0.0d0
+
+ l_z = d_z
+ xy = k_x/k_y
+ yx = k_y/k_x
+ r_b = 0.28d0*sqrt((sqrt(xy)*d_y**2+sqrt(yx)*d_x**2))/ &
+ (xy**0.25+yx**0.25)
+ wi_z = 2.0d0*pi*sqrt(k_x*k_y)*l_z/(log(r_b/r_w)+skin)
+
+ wi_pj = sqrt(wi_x**2 + wi_y**2 + wi_z**2)
+
+ bhpr = pres(i,j,k,ismpl)+val*visf(i,j,k,ismpl)/wi_pj
+
+ dbc_data(ib,3,ismpl) = bhpr
+
+ END IF
+ END IF
+!
+ END DO
+!
+ RETURN
+ END
diff --git a/forward/check_change.f90 b/forward/check_change.f90
new file mode 100644
index 0000000..9622e78
--- /dev/null
+++ b/forward/check_change.f90
@@ -0,0 +1,134 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief check changes between vectors [new] and [old]
+!> @param[in] mode switch absolute/relative
+!> @param[out] rms return value
+!> @param[out] difmax maximal difference
+!> @param[in] ni I-dimension for vectors [new], [old]
+!> @param[in] nj J-dimension for vectors [new], [old]
+!> @param[in] nk K-dimension for vectors [new], [old]
+!> @param[in] new vector with new values
+!> @param[in] old vector with old values
+!> @param[in] pv_idx index number (physical value), only needed for AD code generation/modification
+!> @param[out] loc_nltol tolerance criteria, only needed for AD code generation/modification
+!> @param[in] ismpl local sample index
+!> @details
+!> Computes two difference metrics between the physical variable array
+!> of this iteration (new) and the one from the previous iteration
+!> (old): \n\n
+!>
+!> 1. difmax : max. difference of fields new and old\n
+!> mode= 0 : difmax is absolute maximum difference\n
+!> else : difmax is relative maximum difference\n\n
+!>
+!> 2. rms : root mean square difference of fields new and old
+!> mode= 0 : rms is root mean square of absolute differences\n
+!> else : rms is root mean square of relative differences\n\n
+ SUBROUTINE check_change(mode,pv_idx,loc_nltol,rms,difmax,ni,nj,nk,new,old,ismpl)
+
+ use arrays
+ use mod_linfos
+
+ IMPLICIT NONE
+
+ INTEGER i, j, k, ni, nj, nk, ijk, ipt, jpt, kpt, mode, pv_idx, ismpl
+ DOUBLE PRECISION new(ni,nj,nk), old(ni,nj,nk)
+ ! DOUBLE PRECISION dif
+ DOUBLE PRECISION rms, difmax, loc_nltol
+ INTEGER idamax
+ EXTERNAL idamax
+ INTRINSIC dabs, dble, sqrt
+
+
+ IF (linfos(3)>=2) WRITE(*,*) ' ... check_change'
+
+ ! Initial values for output
+ rms = 0.D0
+ difmax = 0.D0
+ ipt = 0
+ jpt = 0
+ kpt = 0
+
+ IF (mode==0) THEN
+ ! Absolute difference
+
+ ! Number of cells
+ ijk = ni*nj*nk
+
+ ! Copy new values to x
+ CALL dcopy(ijk,new,1,x(1,1,1,ismpl),1)
+
+ ! Absolute difference array: new - old
+ CALL daxpy(ijk,-1.0d0,old,1,x(1,1,1,ismpl),1)
+
+ ! Indices of maximum absolute difference
+ i = idamax(ijk,x(1,1,1,ismpl),1)
+ CALL ijk_m(i,ipt,jpt,kpt)
+
+ ! Maximum absolute difference
+ difmax = x(ipt,jpt,kpt,ismpl)
+
+ ! Sum of squares
+ CALL s_ddot(ijk,x(1,1,1,ismpl),x(1,1,1,ismpl),rms)
+
+ ELSE
+ ! Relative difference (currently not used)
+
+ ! Number of cells
+ ijk = ni*nj*nk
+
+ ! Copy new values to x
+ CALL dcopy(ijk,new,1,x(1,1,1,ismpl),1)
+
+ ! Relative difference array (new - old)/old
+ CALL daxpy(ijk,-1.0d0,old,1,x(1,1,1,ismpl),1)
+ DO k = 1, nk
+ DO j = 1, nj
+ DO i = 1, ni
+ IF (dabs(old(i,j,k))>1.D-200) x(i,j,k,ismpl) = x(i,j,k,ismpl)/old(i,j,k)
+ END DO
+ END DO
+ END DO
+
+ ! Indices of maximum relative difference
+ i = idamax(ijk,x(1,1,1,ismpl),1)
+ CALL ijk_m(i,ipt,jpt,kpt)
+
+ ! Maximum relative difference
+ difmax = x(ipt,jpt,kpt,ismpl)
+
+ ! Sum of squares
+ CALL s_ddot(ijk,x(1,1,1,ismpl),x(1,1,1,ismpl),rms)
+
+ END IF
+
+ ! Root-Mean part of the RMSE
+ rms = sqrt(rms/dble(ijk))
+
+ ! Standard output
+ IF (linfos(3)>=2) WRITE(*,'(A,1e12.5,A,1e12.5,3(A,i5),A)') &
+ ' nl iteration rms =', rms, ', difmax =', difmax, ', [', &
+ ipt, ',', jpt, ',', kpt, ']'
+
+ RETURN
+ END
diff --git a/forward/check_props.f90 b/forward/check_props.f90
new file mode 100644
index 0000000..b31c005
--- /dev/null
+++ b/forward/check_props.f90
@@ -0,0 +1,76 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief compute reference value of "rhof"
+!> @param[in] ismpl local sample index
+!> @details
+!> recompute the reference value [rref] and\n
+!> makes a sanity proof with the given (default) one\n
+ SUBROUTINE check_props(ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_flow
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION rmin, rmax, ravrg, rlocal, rhof
+ EXTERNAL rhof
+
+#ifdef head_base
+! check rref
+ rmin = rhof(1,1,1,ismpl)
+ rmax = rhof(1,1,1,ismpl)
+ ravrg = 0.D0
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ rlocal = rhof(i,j,k,ismpl)
+ ravrg = ravrg + rlocal
+ rmin = min(rlocal,rmin)
+ rmax = max(rlocal,rmax)
+ END DO
+ END DO
+ END DO
+ ravrg = ravrg/dble(i0*j0*k0)
+!
+ IF (rref>rmax) THEN
+ WRITE(*,'(1A,1e12.4,1A)') 'error: rref=', rref, &
+ ' not consistent'
+ WRITE(*,'(3A,4(1e12.4,1A))') &
+ 'You should explicitely define a ',&
+ 'section "'//key_char//' rref" with ', &
+ 'a value like ', rmax, &
+ ', calulated range [', rmin, ', ', ravrg, ', ', rmax, &
+ '] !!!'
+ rref=rmax
+!vr rref=ravrg
+ WRITE(*,'(1A,1e12.4,1A)') 'rref set to:', rref, &
+ ' (= rmax)'
+ END IF
+!
+#endif
+
+ RETURN
+ END
diff --git a/forward/check_units.f90 b/forward/check_units.f90
new file mode 100644
index 0000000..bc0624a
--- /dev/null
+++ b/forward/check_units.f90
@@ -0,0 +1,161 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief prove the thickness for each unit layer
+!> @param[in] ismpl local sample index
+!> @details
+!> count for each rock layer the number of cell neighbours\n
+!> and warns about small layers (currently disabled !!!)\n
+ SUBROUTINE check_units(ismpl)
+ use arrays
+ use mod_genrl
+ IMPLICIT NONE
+! counts the directions (thickness large enough)
+ INTEGER icount
+! current unit, min. thickness criteria, ()
+ INTEGER un, xdcrit, lines
+! delta offset for neighbours
+ INTEGER d_i, d_j, d_k
+! interval 'i':[iv,ib]
+ INTEGER iv_, ib_, id_
+! interval 'j':[jv_,jb_]
+ INTEGER jv_, jb_, jd_
+! interval 'k':[kv_,kb_]
+ INTEGER kv_, kb_, kd_
+! counts all to small areas for each unit
+ INTEGER, ALLOCATABLE :: warn(:,:)
+! : in percentage
+ DOUBLE PRECISION warn_p
+ integer :: i
+ integer :: j
+ integer :: k
+ integer :: ismpl
+
+! --- routine disabled !!! ---
+ RETURN
+! --- routine disabled !!! ---
+
+! init.
+ lines = 0
+ ALLOCATE(warn(maxunits,2))
+ DO i = 1, maxunits
+ warn(i,1) = 0
+ warn(i,2) = 0
+ END DO
+
+! setup all ranges
+ iv_ = 3
+ ib_ = i0 - 2
+ id_ = 1
+ IF (i0<5) THEN
+! disable this dimension
+ iv_ = 1
+ ib_ = i0
+ id_ = 0
+ END IF
+ jv_ = 3
+ jb_ = j0 - 2
+ jd_ = 1
+ IF (j0<5) THEN
+! disable this dimension
+ jv_ = 1
+ jb_ = j0
+ jd_ = 0
+ END IF
+ kv_ = 3
+ kb_ = k0 - 2
+ kd_ = 1
+ IF (k0<5) THEN
+! disable this dimension
+ kv_ = 1
+ kb_ = k0
+ kd_ = 0
+ END IF
+
+! setup right criteria
+ IF (id_+jd_+kd_==1) THEN
+! 1D criteria
+ xdcrit = 1
+ ELSE IF (id_+jd_+kd_==2) THEN
+! 2D criteria
+ xdcrit = 3
+ ELSE
+! 3D criteria
+ xdcrit = 7
+ END IF
+
+! analyse all inner elements
+ DO k = kv_, kb_
+ DO j = jv_, jb_
+ DO i = iv_, ib_
+! current unit number
+ un = uindex(i,j,k)
+ icount = 0
+! prove for all directions
+ DO d_k = -kd_, + kd_
+ DO d_j = -jd_, + jd_
+ DO d_i = -id_, + id_
+ IF ((d_i/=0) .OR. (d_j/=0) .OR. (d_k/=0)) THEN
+ IF (((uindex(i+d_i,j+d_j,k+d_k)== &
+ un) .AND. (uindex(i-d_i,j-d_j,k-d_k)== &
+ un)) .OR. ((uindex(i+d_i,j+d_j,k+d_k)== &
+ un) .AND. (uindex(i+2*d_i,j+2*d_j,k+2*d_k)== &
+ un)) .OR. ((uindex(i-d_i,j-d_j,k-d_k)== &
+ un) .AND. (uindex(i-2*d_i,j-2*d_j,k-2*d_k)== &
+ un))) icount = icount + 1
+ END IF
+ END DO
+ END DO
+ END DO
+
+ IF ((icount/2)<xdcrit) THEN
+! thickness to small !!!
+ warn(un,1) = warn(un,1) + 1
+ ELSE
+! enough thickness !!!
+ warn(un,2) = warn(un,2) + 1
+ END IF
+ END DO
+ END DO
+ END DO
+
+! make an output for all units layers which are to small
+ DO i = 1, maxunits
+ IF (warn(i,1)+warn(i,2)>27) THEN
+ warn_p = dble(warn(i,1))/dble(warn(i,1)+warn(i,2))
+ IF (warn_p>0.01D0) THEN
+ IF (lines==0) THEN
+ WRITE(*,*)
+ lines = 1
+ END IF
+ WRITE(*,'(A,I7,A,F5.1,A)') ' *** warning: unit layer ' &
+ , i, ' is too fine (about ', warn_p*100.0D0, '%) ***'
+ END IF
+ END IF
+ END DO
+ IF (lines==1) WRITE(*,*)
+
+! free memory
+ DEALLOCATE(warn)
+
+ RETURN
+ END
diff --git a/forward/conc/calc_conc.f90 b/forward/conc/calc_conc.f90
new file mode 100644
index 0000000..a6790b9
--- /dev/null
+++ b/forward/conc/calc_conc.f90
@@ -0,0 +1,107 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief top level routine for setup and computing tracer concentration
+!> @param[in] species tracer species index
+!> @param[in] ismpl local sample index
+ SUBROUTINE calc_conc(species,ismpl)
+ use arrays
+! use chem_arrays
+ use mod_genrlc
+ use mod_genrl
+ use mod_conc
+ use mod_time
+ use mod_linfos
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i
+ INCLUDE 'OMP_TOOLS.inc'
+ INTEGER ijk, species
+
+
+ IF (linfos(3)>=2) WRITE(*,'(1A,i4)') ' ... calc_conc', &
+ species
+!
+! selecting a part for each thread
+#ifdef fOMP
+!$OMP parallel num_threads(Tlevel_1)
+!$ call omp_binding(ismpl)
+#endif
+
+ ijk = i0*j0*k0
+! default to mark a non-boundary
+!$OMP master
+ DO i = 1, ijk
+ bc_mask(i,ismpl) = '+'
+ END DO
+!$OMP end master
+! initialize coefficients for sparse solvers
+ CALL omp_set_dval(ijk,0.D0,a(1,1,1,ismpl))
+ CALL omp_set_dval(ijk,0.D0,b(1,1,1,ismpl))
+ CALL omp_set_dval(ijk,0.D0,c(1,1,1,ismpl))
+ CALL omp_set_dval(ijk,0.D0,d(1,1,1,ismpl))
+ CALL omp_set_dval(ijk,0.D0,e(1,1,1,ismpl))
+ CALL omp_set_dval(ijk,0.D0,f(1,1,1,ismpl))
+ CALL omp_set_dval(ijk,0.D0,g(1,1,1,ismpl))
+ CALL omp_set_dval(ijk,0.D0,w(1,1,1,ismpl))
+
+!$OMP barrier
+! calculate coefficients
+ CALL set_ccoef(species,ismpl)
+! set energy sources/sinks
+ CALL set_cq(species,ismpl)
+
+!$OMP barrier
+ CALL set_ccoefrs(species,ismpl)
+#ifdef fOMP
+!$OMP end parallel
+#endif
+
+! set boundary conditions
+ CALL set_cbc(species,ismpl)
+
+ IF (linfos(3)>=2) WRITE(*,'(A,i4)') ' calling solve (conc)', &
+ species
+
+! write(99,'(a)') 'AC'
+! write(99,'(10G15.6)') (a(3,3,k,1),k=1,k0)
+! write(99,'(a)') 'BC'
+! write(99,'(10G15.6)') (b(3,3,k,1),k=1,k0)
+! write(99,'(a)') 'CC'
+! write(99,'(10G15.6)') (c(3,3,k,1),k=1,k0)
+! write(99,'(a)') 'DC'
+! write(99,'(10G15.6)') (d(3,3,k,1),k=1,k0)
+! write(99,'(a)') 'EC'
+! write(99,'(10G15.6)') (e(3,3,k,1),k=1,k0)
+! write(99,'(a)') 'FC'
+! write(99,'(10G15.6)') (f(3,3,k,1),k=1,k0)
+! write(99,'(a)') 'GC'
+! write(99,'(10G15.6)') (g(3,3,k,1),k=1,k0)
+! write(99,'(a)') 'WC'
+! write(99,'(10G15.6)') (w(3,3,k,1),k=1,k0)
+! solve it
+ CALL solve(pv_conc,species,conc(1,1,1,species,ismpl),errc, &
+ aparc,controlc,ismpl)
+
+ RETURN
+ END
diff --git a/forward/conc/cfluxes.f90 b/forward/conc/cfluxes.f90
new file mode 100644
index 0000000..e5375b3
--- /dev/null
+++ b/forward/conc/cfluxes.f90
@@ -0,0 +1,338 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculate x mass flux at cell faces
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] l species
+!> @param[in] ismpl local sample index
+!> @return x mass flux
+ DOUBLE PRECISION FUNCTION sx(i,j,k,l,ismpl)
+ use arrays
+ use mod_genrl
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k, l
+ DOUBLE PRECISION dif, di
+ EXTERNAL di
+
+ sx = 0.D0
+ IF (i0>1 .AND. i<i0) THEN
+ dif = conc(i+1,j,k,l,ismpl) - conc(i,j,k,l,ismpl)
+ sx = -di(i,j,k,l,ismpl)*dif
+ END IF
+
+ RETURN
+ END
+
+!> @brief calculate y mass flux at cell faces
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] l species
+!> @param[in] ismpl local sample index
+!> @return y mass flux
+ DOUBLE PRECISION FUNCTION sy(i,j,k,l,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_temp
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k, l
+
+ DOUBLE PRECISION dif, dj
+ EXTERNAL dj
+
+ sy = 0.D0
+ IF (j0>1 .AND. j<j0) THEN
+ dif = conc(i,j+1,k,l,ismpl) - conc(i,j,k,l,ismpl)
+ sy = -dj(i,j,k,l,ismpl)*dif
+ END IF
+
+ RETURN
+ END
+
+!> @brief calculate z mass flux at cell faces
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] l species
+!> @param[in] ismpl local sample index
+!> @return z mass flux
+ DOUBLE PRECISION FUNCTION sz(i,j,k,l,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_temp
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k, l
+
+ DOUBLE PRECISION dif, dk
+ EXTERNAL dk
+
+ sz = 0.D0
+ IF (k0>1 .AND. k<k0) THEN
+ dif = conc(i,j,k+1,l,ismpl) - conc(i,j,k,l,ismpl)
+ sz = -dk(i,j,k,l,ismpl)*dif
+ END IF
+
+ RETURN
+ END
+
+!> @brief calculate x mass flux at cell centers
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] l species
+!> @param[in] ismpl local sample index
+!> @return x mass flux
+ DOUBLE PRECISION FUNCTION sxc(i,j,k,l,ismpl)
+ use arrays
+ use mod_genrl
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k, l
+ DOUBLE PRECISION d1, d2, di, amean
+ EXTERNAL di, amean
+
+ sxc = 0.D0
+ IF (i0<=1) RETURN
+ IF (i>1 .AND. i<i0) THEN
+ d1 = conc(i+1,j,k,l,ismpl) - conc(i,j,k,l,ismpl)
+ d2 = conc(i,j,k,l,ismpl) - conc(i-1,j,k,l,ismpl)
+ sxc = amean(-di(i,j,k,l,ismpl)*d1,-di(i-1,j,k,l,ismpl)*d2)
+ ELSE IF (i==1) THEN
+ sxc = -di(i,j,k,l,ismpl)*(conc(i+1,j,k,l,ismpl)-conc(i,j,k,l &
+ ,ismpl))
+ ELSE IF (i==i0) THEN
+ sxc = -di(i-1,j,k,l,ismpl)*(conc(i,j,k,l,ismpl)-conc(i-1,j,k &
+ ,l,ismpl))
+ END IF
+
+ RETURN
+ END
+
+!> @brief calculate y mass fluxat cell center
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] l species
+!> @param[in] ismpl local sample index
+!> @return y mass flux
+ DOUBLE PRECISION FUNCTION syc(i,j,k,l,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_temp
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k, l
+
+ DOUBLE PRECISION d1, d2, dj, amean
+ EXTERNAL dj, amean
+
+ syc = 0.D0
+ IF (j0<=1) RETURN
+ IF (j>1 .AND. j<j0) THEN
+ d1 = conc(i,j+1,k,l,ismpl) - conc(i,j,k,l,ismpl)
+ d2 = conc(i,j,k,l,ismpl) - conc(i,j-1,k,l,ismpl)
+ syc = amean(-dj(i,j,k,l,ismpl)*d1,-dj(i,j-1,k,l,ismpl)*d2)
+ ELSE IF (j==1) THEN
+ syc = -dj(i,j,k,l,ismpl)*(conc(i,j+1,k,l,ismpl)-conc(i,j,k,l &
+ ,ismpl))
+ ELSE IF (j==j0) THEN
+ syc = -dj(i,j-1,k,l,ismpl)*(conc(i,j,k,l,ismpl)-conc(i,j-1,k &
+ ,l,ismpl))
+ END IF
+
+ RETURN
+ END
+
+!> @brief calculate z mass flux at cell center
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] l species
+!> @param[in] ismpl local sample index
+!> @return z mass flux
+ DOUBLE PRECISION FUNCTION szc(i,j,k,l,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_temp
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k, l
+
+ DOUBLE PRECISION d1, d2, dk, amean
+ EXTERNAL dk, amean
+
+ szc = 0.D0
+ IF (k0<=1) RETURN
+ IF (k>1 .AND. k<k0) THEN
+ d1 = conc(i,j,k+1,l,ismpl) - conc(i,j,k,l,ismpl)
+ d2 = conc(i,j,k,l,ismpl) - conc(i,j,k-1,l,ismpl)
+ szc = amean(-dk(i,j,k,l,ismpl)*d1,-dk(i,j,k-1,l,ismpl)*d2)
+ ELSE IF (k==1) THEN
+ szc = -dk(i,j,k,l,ismpl)*(conc(i,j,k+1,l,ismpl)-conc(i,j,k,l &
+ ,ismpl))
+ ELSE IF (k==k0) THEN
+ szc = -dk(i,j,k-1,l,ismpl)*(conc(i,j,k,l,ismpl)-conc(i,j,k-1 &
+ ,l,ismpl))
+ END IF
+
+ RETURN
+ END
+
+!> @brief average effective diffusivities on cell faces in x direction
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] spec species
+!> @param[in] ismpl local sample index
+!> @return effective diffusivities (J/mK)
+ DOUBLE PRECISION FUNCTION di(i,j,k,spec,ismpl)
+ use arrays
+ use mod_genrl
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+ INTEGER spec
+ DOUBLE PRECISION f1, f2, prod, summ, betx, bety, betz, bet
+ DOUBLE PRECISION por, disp, vx, vy, vz
+ EXTERNAL por, disp, vx, vy, vz
+
+ di = 0.D0
+ betx = 0.D0
+ bety = 0.D0
+ betz = 0.D0
+ IF (k0>1 .AND. k<k0) THEN
+ betz = vz(i,j,k,ismpl)
+ betz = betz*betz
+ END IF
+ IF (j0>1 .AND. j<j0) THEN
+ bety = vy(i,j,k,ismpl)
+ bety = bety*bety
+ END IF
+ IF (i0>1 .AND. i<i0) THEN
+ betx = vx(i,j,k,ismpl)
+ betx = betx*betx
+ bet = SQRT(betx + bety + betz)
+ f1 = por(i,j,k,ismpl)*diff_c(spec) + disp(i,j,k,ismpl)*bet
+ f2 = por(i+1,j,k,ismpl)*diff_c(spec) + &
+ disp(i+1,j,k,ismpl)*bet
+ prod = f1*f2
+ summ = f1*delx(i+1) + f2*delx(i)
+ IF (summ>0.D0) di = 2.D0*prod/summ
+ END IF
+
+ RETURN
+ END
+
+!> @brief average effective diffusivities on cell faces in y direction
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] spec species
+!> @param[in] ismpl local sample index
+!> @return effective diffusivities (J/mK)
+ DOUBLE PRECISION FUNCTION dj(i,j,k,spec,ismpl)
+ use arrays
+ use mod_genrl
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+ INTEGER spec
+ DOUBLE PRECISION f1, f2, prod, summ, betx, bety, betz, bet
+ DOUBLE PRECISION por, disp, vy, vx, vz
+ EXTERNAL por, disp, vy, vx, vz
+
+ dj = 0.D0
+ betx = 0.D0
+ bety = 0.D0
+ betz = 0.D0
+ IF (k0>1 .AND. k<k0) THEN
+ betz = vz(i,j,k,ismpl)
+ betz = betz*betz
+ END IF
+ IF (i0>1 .AND. i<i0) THEN
+ betx = vx(i,j,k,ismpl)
+ betx = betx*betx
+ END IF
+ IF (j0>1 .AND. j<j0) THEN
+ bety = vy(i,j,k,ismpl)
+ bety = bety*bety
+ bet = SQRT(betx + bety + betz)
+ f1 = por(i,j,k,ismpl)*diff_c(spec) + disp(i,j,k,ismpl)*bet
+ f2 = por(i,j+1,k,ismpl)*diff_c(spec) + &
+ disp(i,j+1,k,ismpl)*bet
+ prod = f1*f2
+ summ = f1*dely(j+1) + f2*dely(j)
+ IF (summ>0.D0) dj = 2.D0*prod/summ
+ END IF
+
+ RETURN
+ END
+
+!> @brief average effective diffusivities on cell faces in z direction
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] spec species
+!> @param[in] ismpl local sample index
+!> @return effective diffusivities (J/mK)
+ DOUBLE PRECISION FUNCTION dk(i,j,k,spec,ismpl)
+ use arrays
+ use mod_genrl
+ IMPLICIT NONE
+ integer :: i, j, k
+ integer :: ismpl
+ INTEGER spec
+ DOUBLE PRECISION f1, f2, prod, summ, betx, bety, betz, bet
+ DOUBLE PRECISION por, disp, vz, vy, vx
+ EXTERNAL por, disp, vz, vy, vx
+
+ dk = 0.D0
+ betx = 0.D0
+ bety = 0.D0
+ betz = 0.D0
+ IF (j0>1 .AND. j<j0) THEN
+ bety = vy(i,j,k,ismpl)
+ bety = bety*bety
+ END IF
+ IF (i0>1 .AND. i<i0) THEN
+ betx = vx(i,j,k,ismpl)
+ betx = betx*betx
+ END IF
+ IF (k0>1 .AND. k<k0) THEN
+ betz = vz(i,j,k,ismpl)
+ betz = betz*betz
+ bet = SQRT(betx + bety + betz)
+ f1 = por(i,j,k,ismpl)*diff_c(spec) + disp(i,j,k,ismpl)*bet
+ f2 = por(i,j,k+1,ismpl)*diff_c(spec) + &
+ disp(i,j,k+1,ismpl)*bet
+ prod = f1*f2
+ summ = f1*delz(k+1) + f2*delz(k)
+ IF (summ>0.D0) dk = 2.D0*prod/summ
+ END IF
+
+ RETURN
+ END
diff --git a/forward/conc/neumann_conc.f90 b/forward/conc/neumann_conc.f90
new file mode 100644
index 0000000..ec981b6
--- /dev/null
+++ b/forward/conc/neumann_conc.f90
@@ -0,0 +1,215 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief OpenMP wrapper for "omp_neumann_conc"
+!> @param[out] neumann_max neumann criteria
+!> @param[in] ismpl local sample index
+ SUBROUTINE neumann_conc(neumann_max,ismpl)
+ use mod_genrl
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ integer :: ismpl
+ INCLUDE 'OMP_TOOLS.inc'
+ DOUBLE PRECISION neumann_max
+
+#ifdef fOMP
+!$OMP parallel num_threads(Tlevel_1)
+!$ call omp_binding(ismpl)
+#endif
+ CALL omp_neumann_conc(neumann_max,ismpl)
+#ifdef fOMP
+!$OMP end parallel
+#endif
+
+ RETURN
+ END
+
+!> @brief calculate grid neuman numbers (transport)
+!> @param[out] neumann_max neumann criteria
+!> @param[in] ismpl local sample index
+ SUBROUTINE omp_neumann_conc(neumann_max,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_conc
+ use mod_time
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+
+ INTEGER c1, c2, c3
+ DOUBLE PRECISION neumann_maxx, neumann_minx, neumann_avgx
+ DOUBLE PRECISION neumann_maxy, neumann_miny, neumann_avgy, neumann_maxz
+ DOUBLE PRECISION neumann_minz, neumann_avgz
+ DOUBLE PRECISION val, neumann_max, delt, fac, davg
+ DOUBLE PRECISION deltat
+ EXTERNAL deltat
+
+ DOUBLE PRECISION di, dj, dk, por
+ EXTERNAL di, dj, dk, por
+
+ INTEGER ispec
+
+
+ delt = deltat(simtime(ismpl),ismpl)
+
+ IF ( .NOT. (transient .AND. tr_switch(ismpl))) THEN
+!$OMP master
+ WRITE(*,*) ' neumann-conc: not defined for steady state'
+!$OMP end master
+ RETURN
+ ELSE IF (linfos(3)>=2) THEN
+!$OMP master
+ WRITE(*,*)
+ WRITE(*,'(A,1e16.8)') ' ... neumann-conc: delt/tunit = ', &
+ delt/tunit
+ WRITE(*,*)
+!$OMP end master
+ END IF
+
+! --------- species ---------
+ DO ispec = 1, ntrans
+
+ c1 = 0
+ neumann_maxx = small
+ neumann_minx = big
+ neumann_avgx = 0.0D0
+!$OMP do schedule(static)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 2, i0 - 1
+ c1 = c1 + 1
+ davg = 0.5D0*(delx(i)+delx(i+1))
+ fac = delt/por(i,j,k,ismpl)
+ val = fac*di(i,j,k,ispec,ismpl)/(davg*davg)
+ IF (val>neumann_maxx) neumann_maxx = val
+ IF (val<neumann_minx) neumann_minx = val
+ neumann_avgx = neumann_avgx + val
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+
+! val in y
+ c2 = 0
+ neumann_maxy = small
+ neumann_miny = big
+ neumann_avgy = 0.0D0
+!$OMP do schedule(static)
+ DO k = 1, k0
+ DO j = 2, j0 - 1
+ DO i = 1, i0
+ c2 = c2 + 1
+ davg = 0.5D0*(dely(j)+dely(j+1))
+ fac = delt/por(i,j,k,ismpl)
+ val = fac*dj(i,j,k,ispec,ismpl)/(davg*davg)
+ IF (val>neumann_maxy) neumann_maxy = val
+ IF (val<neumann_miny) neumann_miny = val
+ neumann_avgy = neumann_avgy + val
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+
+! val in z
+ c3 = 0
+ neumann_maxz = small
+ neumann_minz = big
+ neumann_avgz = 0.0D0
+!$OMP do schedule(static)
+ DO k = 2, k0 - 1
+ DO j = 1, j0
+ DO i = 1, i0
+ c3 = c3 + 1
+ davg = 0.5D0*(delz(k)+delz(k+1))
+ fac = delt/por(i,j,k,ismpl)
+ val = fac*dk(i,j,k,ispec,ismpl)/(davg*davg)
+ IF (val>neumann_maxz) neumann_maxz = val
+ IF (val<neumann_minz) neumann_minz = val
+ neumann_avgz = neumann_avgz + val
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+
+! compute global sum for all values
+ CALL omp_summe(neumann_maxx,neumann_minx,neumann_avgx, &
+ neumann_maxy,neumann_miny,neumann_avgy,neumann_maxz, &
+ neumann_minz,neumann_avgz,c1,c2,c3,ismpl)
+
+!$OMP master
+ IF (i0>2) THEN
+ neumann_avgx = neumann_avgx/dble(c1)
+ ELSE
+ neumann_maxx = 0.0D0
+ neumann_minx = 0.0D0
+ neumann_avgx = 0.0D0
+ END IF
+ IF (j0>2) THEN
+ neumann_avgy = neumann_avgy/dble(c2)
+ ELSE
+ neumann_maxy = 0.0D0
+ neumann_miny = 0.0D0
+ neumann_avgy = 0.0D0
+ END IF
+ IF (k0>2) THEN
+ neumann_avgz = neumann_avgz/dble(c3)
+ ELSE
+ neumann_maxz = 0.0D0
+ neumann_minz = 0.0D0
+ neumann_avgz = 0.0D0
+ END IF
+
+ neumann_max = max(neumann_maxx,neumann_maxy,neumann_maxz)
+
+ IF (linfos(3)>=2) THEN
+ WRITE(*,'(1A,1I3,1A)') &
+ ' neumann number for transport (species ', ispec, &
+ ') in x,y,z:'
+ WRITE(*,'(a,1e10.3,a,1e10.3,a,1e10.3)') ' max. : ', &
+ neumann_maxx, ', ', neumann_maxy, ', ', &
+ neumann_maxz
+ WRITE(*,'(a,1e10.3,a,1e10.3,a,1e10.3)') ' min. : ', &
+ neumann_minx, ', ', neumann_miny, ', ', &
+ neumann_minz
+ WRITE(*,'(a,1e10.3,a,1e10.3,a,1e10.3)') ' avg. : ', &
+ neumann_avgx, ', ', neumann_avgy, ', ', &
+ neumann_avgz
+ END IF
+
+ IF (linfos(3)>=1 .AND. neumann_max>1.D0) THEN
+ WRITE(*,'(1A,1I3,1A)') &
+ '!!!: neumann temp number (species ', ispec, &
+ ') greater than 1 :'
+ WRITE(*,'(a,1e12.3,a,1e10.3,a,1e10.3)') 'x: ', &
+ neumann_maxx, 'y: ', neumann_maxy, 'z: ', neumann_maxz
+ WRITE(*,*)
+ END IF
+!$OMP end master
+
+ END DO
+! --------- species ---------
+
+ RETURN
+ END
diff --git a/forward/conc/peclet_conc.f90 b/forward/conc/peclet_conc.f90
new file mode 100644
index 0000000..ab8b56a
--- /dev/null
+++ b/forward/conc/peclet_conc.f90
@@ -0,0 +1,226 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief OpenMP wrapper for "omp_peclet_conc"
+!> @param[out] peclet_max peclet number/criteria
+!> @param[in] ismpl local sample index
+ SUBROUTINE peclet_conc(peclet_max,ismpl)
+ use mod_genrl
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ integer :: ismpl
+ INCLUDE 'OMP_TOOLS.inc'
+ DOUBLE PRECISION peclet_max
+
+#ifdef fOMP
+!$OMP parallel num_threads(Tlevel_1)
+!$ call omp_binding(ismpl)
+#endif
+ CALL omp_peclet_conc(peclet_max,ismpl)
+#ifdef fOMP
+!$OMP end parallel
+#endif
+!
+ RETURN
+ END
+
+!> @brief calculate grid peclet numbers (transport)
+!> @param[out] peclet_max peclet number/criteria
+!> @param[in] ismpl local sample index
+ SUBROUTINE omp_peclet_conc(peclet_max,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_conc
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ INTEGER c1, c2, c3
+ DOUBLE PRECISION peclet_maxx, peclet_minx, peclet_avgx, &
+ peclet_maxy, peclet_miny, peclet_avgy, peclet_maxz, &
+ peclet_minz, peclet_avgz, val, davg, peclet_max
+ INTEGER ipt, jpt, kpt
+ DOUBLE PRECISION di, dj, dk, vx, vy, vz, por
+ EXTERNAL di, dj, dk, vx, vy, vz, por
+ INTEGER ispec
+
+ IF (linfos(3)>=2) THEN
+!$OMP master
+ WRITE(*,*)
+ WRITE(*,'(A,1e16.8)') ' ... peclet-conc'
+ WRITE(*,*)
+!$OMP end master
+ END IF
+!
+! -------- species --------
+ DO ispec = 1, ntrans
+! temperature-val in x
+ peclet_maxx = small
+ peclet_minx = big
+ peclet_avgx = 0.0D0
+ val = 0.0D0
+ ipt = 0
+ jpt = 0
+ kpt = 0
+ c1 = 0
+!$OMP do schedule(static)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 2, i0 - 1
+ c1 = c1 + 1
+ davg = 0.5D0*(delx(i)+delx(i+1))
+ val = abs(vx(i,j,k,ismpl))*davg/di(i,j,k,ispec,ismpl)
+ IF (val>peclet_maxx) THEN
+ peclet_maxx = val
+ ipt = i
+ jpt = j
+ kpt = k
+ END IF
+ IF (val<peclet_minx) peclet_minx = val
+ peclet_avgx = peclet_avgx + val
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+! if (linfos(3).ge.2)write(*,*)
+! & "max. temp-val in x: ", ipt,jpt,kpt
+!
+! temperature-val in y
+ peclet_maxy = small
+ peclet_miny = big
+ peclet_avgy = 0.0D0
+ val = 0.0D0
+ ipt = 0
+ jpt = 0
+ kpt = 0
+ c2 = 0
+!$OMP do schedule(static)
+ DO k = 1, k0
+ DO j = 2, j0 - 1
+ DO i = 1, i0
+ c2 = c2 + 1
+ davg = 0.5D0*(dely(j)+dely(j+1))
+ val = abs(vy(i,j,k,ismpl))*davg/dj(i,j,k,ispec,ismpl)
+ IF (val>peclet_maxy) THEN
+ peclet_maxy = val
+ ipt = i
+ jpt = j
+ kpt = k
+ END IF
+ IF (val<peclet_miny) peclet_miny = val
+ peclet_avgy = peclet_avgy + val
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+! if(linfos(3).ge.2)
+! & write(*,*)"max. temp-val in y: " ,ipt,jpt,kpt
+!
+! temperature-val in z
+ peclet_maxz = small
+ peclet_minz = big
+ peclet_avgz = 0.0D0
+ val = 0.0D0
+ ipt = 0
+ jpt = 0
+ kpt = 0
+ c3 = 0
+!$OMP do schedule(static)
+ DO k = 2, k0 - 1
+ DO j = 1, j0
+ DO i = 1, i0
+ c3 = c3 + 1
+ davg = 0.5D0*(delz(k)+delz(k+1))
+ val = abs(vz(i,j,k,ismpl))*davg/dk(i,j,k,ispec,ismpl)
+ IF (val>peclet_maxz) THEN
+ peclet_maxz = val
+ ipt = i
+ jpt = j
+ kpt = k
+ END IF
+ IF (val<peclet_minz) peclet_minz = val
+ peclet_avgz = peclet_avgz + val
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+! if(linfos(3).ge.2)
+! & write(*,*)"max. temp-val in z: " ,ipt,jpt,kpt
+!
+! compute global sum for all values
+ CALL omp_summe(peclet_maxx,peclet_minx,peclet_avgx, &
+ peclet_maxy,peclet_miny,peclet_avgy,peclet_maxz, &
+ peclet_minz,peclet_avgz,c1,c2,c3,ismpl)
+!
+!$OMP master
+ IF (i0>2) THEN
+ peclet_avgx = peclet_avgx/dble(c1)
+ ELSE
+ peclet_maxx = 0.0D0
+ peclet_minx = 0.0D0
+ peclet_avgx = 0.0D0
+ END IF
+ IF (j0>2) THEN
+ peclet_avgy = peclet_avgy/dble(c2)
+ ELSE
+ peclet_maxy = 0.0D0
+ peclet_miny = 0.0D0
+ peclet_avgy = 0.0D0
+ END IF
+ IF (k0>2) THEN
+ peclet_avgz = peclet_avgz/dble(c3)
+ ELSE
+ peclet_maxz = 0.0D0
+ peclet_minz = 0.0D0
+ peclet_avgz = 0.0D0
+ END IF
+!
+ peclet_max = max(peclet_avgx,peclet_avgy,peclet_avgz)
+!
+ IF (linfos(3)>=2) THEN
+ WRITE(*,'(1A,1I3,1A)') &
+ ' peclet number for transport (species ', ispec, &
+ ') in x,y,z:'
+ WRITE(*,'(a,1e12.3,a,1e10.3,a,1e10.3)') ' max. : ', &
+ peclet_maxx, ', ', peclet_maxy, ', ', peclet_maxz
+ WRITE(*,'(a,1e12.3,a,1e10.3,a,1e10.3)') ' min. : ', &
+ peclet_minx, ', ', peclet_miny, ', ', peclet_minz
+ WRITE(*,'(a,1e12.3,a,1e10.3,a,1e10.3)') ' avg. : ', &
+ peclet_avgx, ', ', peclet_avgy, ', ', peclet_avgz
+ END IF
+!
+ IF (peclet_max>2.0D0 .AND. linfos(3)>=1) THEN
+ WRITE(*,'(1A,1I3,1A)') &
+ '!!!: peclet number for transport (species ', ispec, &
+ ' > 2 :'
+ WRITE(*,'(a,1e12.3,a,1e10.3,a,1e10.3)') 'x: ', &
+ peclet_maxx, 'y: ', peclet_maxy, 'z: ', peclet_maxz
+ END IF
+!$OMP end master
+!
+ END DO
+! -------- species --------
+!
+ RETURN
+ END
diff --git a/forward/conc/set_cbc.f90 b/forward/conc/set_cbc.f90
new file mode 100644
index 0000000..3bfef03
--- /dev/null
+++ b/forward/conc/set_cbc.f90
@@ -0,0 +1,226 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief modify coefficents for the species equation according to the boundary
+!> @param[in] spec species index
+!> @param[in] ismpl local sample index
+!> @details
+!> modify coefficents for the species equation according to the boundary conditions\n
+!> coefficients are stored as vectors in the diagonals a-g (d center) and rhs in w.\n
+ SUBROUTINE set_cbc(spec,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_conc
+ use mod_time
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+ integer :: ib
+ INTEGER bcu, tpbcu, bctype, i_dir, spec, i_spec
+ DOUBLE PRECISION val, malfa, mbeta, vx, vy, vz, dv, ds, vv
+ EXTERNAL vx, vy, vz
+ INTRINSIC max
+
+
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! flow due to flow neumann nodes / wellars - - - - - - - - - - - - - -
+
+ DO ib = first_flow, last_flow
+ i = ibc_data(ib,cbc_i)
+ j = ibc_data(ib,cbc_j)
+ k = ibc_data(ib,cbc_k)
+ bcu = ibc_data(ib,cbc_bcu)
+ tpbcu = max(ibc_data(ib,cbc_bctp),0)
+ bctype = ibc_data(ib,cbc_bt)
+! "neumann"?, skip otherwise
+ IF (bctype==bt_neum.OR.bctype==bt_neuw) THEN
+! discrete values
+ IF (bcu<=0) THEN
+ val = dbc_data(ib,1,ismpl)
+ ELSE
+ val = propunit(bcu,idx_hbc,ismpl)
+ END IF
+
+ IF ((tpbcu>0) .AND. nbctp>0) THEN
+! time-dependent bc: val=ac*val+bc
+! get Alfa and Beta modificators
+ CALL get_tpbcalbe(malfa,mbeta,tpbcu,ismpl)
+! update time dependend modification of the bc-value
+ val = malfa + mbeta*val
+ END IF
+
+! wellar test
+ IF (val<0.0D0 .AND. tpbcu>=0) THEN
+ ds = 0.D0
+ dv = 0.D0
+ IF (i>1) THEN
+ vv = abs(vx(i-1,j,k,ismpl))
+ ds = ds + vv
+ dv = dv + conc(i-1,j,k,spec,ismpl)*vv
+ END IF
+ IF (i<i0) THEN
+ vv = abs(vx(i,j,k,ismpl))
+ ds = ds + vv
+ dv = dv + conc(i+1,j,k,spec,ismpl)*vv
+ END IF
+ IF (j>1) THEN
+ vv = abs(vy(i,j-1,k,ismpl))
+ ds = ds + vv
+ dv = dv + conc(i,j-1,k,spec,ismpl)*vv
+ END IF
+ IF (j<j0) THEN
+ vv = abs(vy(i,j,k,ismpl))
+ ds = ds + vv
+ dv = dv + conc(i,j+1,k,spec,ismpl)*vv
+ END IF
+ IF (k>1) THEN
+ vv = abs(vz(i,j,k-1,ismpl))
+ ds = ds + vv
+ dv = dv + conc(i,j,k-1,spec,ismpl)*vv
+ END IF
+ IF (k<k0) THEN
+ vv = abs(vz(i,j,k,ismpl))
+ ds = ds + vv
+ dv = dv + conc(i,j,k+1,spec,ismpl)*vv
+ END IF
+ dv = dv/ds
+! apply dirichlet update [dv]
+#ifdef BCMY
+! D = D+my
+ d(i,j,k,ismpl) = d(i,j,k,ismpl) - dbc_data(ib,2,ismpl)
+ w(i,j,k,ismpl) = w(i,j,k,ismpl) - &
+ dbc_data(ib,2,ismpl)*dv
+#else
+! standard boundary condition handling
+ a(i,j,k,ismpl) = 0.0D0
+ b(i,j,k,ismpl) = 0.0D0
+ c(i,j,k,ismpl) = 0.0D0
+ e(i,j,k,ismpl) = 0.0D0
+ f(i,j,k,ismpl) = 0.0D0
+ g(i,j,k,ismpl) = 0.0D0
+ d(i,j,k,ismpl) = 1.0D0
+ w(i,j,k,ismpl) = dv
+ conc(i,j,k,spec,ismpl) = dv
+! mark as boundary for normalising the lin. system
+ bc_mask(i+(j-1)*i0+(k-1)*i0*j0,ismpl) = '0'
+#endif
+ END IF
+ END IF
+ END DO
+
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! dirichlet nodes - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ DO ib = first_conc, last_conc
+ i = ibc_data(ib,cbc_i)
+ j = ibc_data(ib,cbc_j)
+ k = ibc_data(ib,cbc_k)
+ bcu = ibc_data(ib,cbc_bcu)
+ tpbcu = max(ibc_data(ib,cbc_bctp),0)
+ bctype = ibc_data(ib,cbc_bt)
+ i_spec = ibc_data(ib,cbc_si)
+! "dirichlet" and "spec"?, skip otherwise
+ IF (bctype==bt_diri .AND. i_spec==spec) THEN
+! discrete values
+ IF (bcu<=0) THEN
+ val = dbc_data(ib,1,ismpl)
+ ELSE
+ val = propunit(bcu,idx_cbc,ismpl)
+ END IF
+
+ IF ((tpbcu>0) .AND. nbctp>0) THEN
+! time-dependent bc: val=ac*val+bc
+! get Alfa and Beta modificators
+ CALL get_tpbcalbe(malfa,mbeta,tpbcu,ismpl)
+! update time dependend modification of the bc-value
+ val = malfa + mbeta*val
+ END IF
+
+ IF (tpbcu>=0) THEN
+#ifdef BCMY
+! D = D+my
+ d(i,j,k,ismpl) = d(i,j,k,ismpl) - dbc_data(ib,2,ismpl)
+ w(i,j,k,ismpl) = w(i,j,k,ismpl) - &
+ dbc_data(ib,2,ismpl)*val
+#else
+! standard boundary condition handling
+ a(i,j,k,ismpl) = 0.0D0
+ b(i,j,k,ismpl) = 0.0D0
+ c(i,j,k,ismpl) = 0.0D0
+ e(i,j,k,ismpl) = 0.0D0
+ f(i,j,k,ismpl) = 0.0D0
+ g(i,j,k,ismpl) = 0.0D0
+ d(i,j,k,ismpl) = 1.0D0
+ w(i,j,k,ismpl) = val
+ conc(i,j,k,spec,ismpl) = val
+! mark as boundary for normalising the lin. system
+ bc_mask(i+(j-1)*i0+(k-1)*i0*j0,ismpl) = '0'
+#endif
+ END IF
+ END IF
+ END DO
+
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! neumann nodes - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ DO ib = first_conc, last_conc
+ i = ibc_data(ib,cbc_i)
+ j = ibc_data(ib,cbc_j)
+ k = ibc_data(ib,cbc_k)
+ bcu = ibc_data(ib,cbc_bcu)
+ tpbcu = max(ibc_data(ib,cbc_bctp),0)
+ bctype = ibc_data(ib,cbc_bt)
+ i_spec = ibc_data(ib,cbc_si)
+ i_dir = ibc_data(ib,cbc_dir)
+! "neumann" and "spec"?, skip otherwise
+ IF (bctype==bt_neum .AND. i_spec==spec) THEN
+! discrete values
+ IF (bcu<=0) THEN
+ val = dbc_data(ib,1,ismpl)
+ ELSE
+ val = propunit(bcu,idx_cbc,ismpl)
+ END IF
+
+ IF ((tpbcu>0) .AND. nbctp>0) THEN
+! time-dependent bc: val=ac*val+bc
+! get Alfa and Beta modificators
+ CALL get_tpbcalbe(malfa,mbeta,tpbcu,ismpl)
+! update time dependend modification of the bc-value
+ val = malfa + mbeta*val
+ END IF
+
+ IF (tpbcu>=0) THEN
+ IF ((i_dir==0)) val = val/(delx(i)*dely(j)*delz(k))
+ IF ((i_dir==1) .OR. (i_dir==2)) val = val/delx(i)
+ IF ((i_dir==3) .OR. (i_dir==4)) val = val/dely(j)
+ IF ((i_dir==5) .OR. (i_dir==6)) val = val/delz(k)
+
+ w(i,j,k,ismpl) = w(i,j,k,ismpl) - val
+ END IF
+ END IF
+ END DO
+
+ RETURN
+ END
diff --git a/forward/conc/set_ccoef.f90 b/forward/conc/set_ccoef.f90
new file mode 100644
index 0000000..dd9f350
--- /dev/null
+++ b/forward/conc/set_ccoef.f90
@@ -0,0 +1,275 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculate coefficents for the transport equation
+!> @param[in] spec species index
+!> @param[in] ismpl local sample index
+!> @details
+!> calculate coefficents for the transport equation\n
+!> coefficients are stored as vectors in the diagonals a-g (d center) and rhs in w.\n
+ SUBROUTINE set_ccoef(spec,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_flow
+ use mod_conc
+ use mod_time
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: i, j, k
+ integer :: ismpl
+ DOUBLE PRECISION di, dj, dk, por, vx, vy, vz, alfa
+ EXTERNAL di, dj, dk, por, vx, vy, vz, alfa
+ DOUBLE PRECISION v2, de, alf, p2
+ INTEGER spec
+!debug write(99,'(a,3i4)') 'ShemSUITE i0,j0,k0:',i0,j0,k0
+
+
+!$OMP master
+ IF (linfos(3)>=2) WRITE(*,*) ' ... ccoef'
+!$OMP end master
+
+! inner points of grid - - - - - - - - - - - - - - - - - - - - - - - - -
+
+!$OMP do schedule(static) collapse(3)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+
+ IF (i0>1) THEN
+ IF (i<i0) THEN
+ de = di(i,j,k,spec,ismpl)
+ v2 = 0.5D0*vx(i,j,k,ismpl)
+ IF (de>0.D0) THEN
+ p2 = v2/de
+ alf = alfa(p2)
+ ELSE
+ alf = 0.D0
+ IF (v2<0.D0) alf = -1.D0
+ IF (v2>0.D0) alf = 1.D0
+ END IF
+ e(i,j,k,ismpl) = (de-(1.D0-alf)*v2)/delx(i)
+ d(i,j,k,ismpl) = d(i,j,k,ismpl) - &
+ (de+(1.D0+alf)*v2)/delx(i)
+ END IF
+
+ IF (i>1) THEN
+ de = di(i-1,j,k,spec,ismpl)
+ v2 = 0.5*vx(i-1,j,k,ismpl)
+ alf = 0.D0
+ IF (v2==0.D0) THEN
+ alf = 0.D0
+ ELSE
+ IF (de>0.D0) THEN
+ p2 = v2/de
+ alf = alfa(p2)
+ ELSE
+ IF (v2<0.D0) alf = -1.D0
+ IF (v2>0.D0) alf = 1.D0
+ END IF
+ END IF
+
+ c(i,j,k,ismpl) = (de+(1.D0+alf)*v2)/delx(i)
+ d(i,j,k,ismpl) = d(i,j,k,ismpl) - &
+ (de-(1.D0-alf)*v2)/delx(i)
+ END IF
+ END IF
+
+
+
+ IF (j0>1) THEN
+
+ IF (j<j0) THEN
+
+ de = dj(i,j,k,spec,ismpl)
+ v2 = 0.5*vy(i,j,k,ismpl)
+ alf = 0.D0
+ IF (v2==0.D0) THEN
+ alf = 0.D0
+ ELSE
+ IF (de>0.D0) THEN
+ p2 = v2/de
+ alf = alfa(p2)
+ ELSE
+ IF (v2<0.D0) alf = -1.D0
+ IF (v2>0.D0) alf = 1.D0
+ END IF
+ END IF
+
+ f(i,j,k,ismpl) = (de-(1.D0-alf)*v2)/dely(j)
+ d(i,j,k,ismpl) = d(i,j,k,ismpl) - &
+ (de+(1.D0+alf)*v2)/dely(j)
+ END IF
+
+
+ IF (j>1) THEN
+
+ de = dj(i,j-1,k,spec,ismpl)
+ v2 = 0.5*vy(i,j-1,k,ismpl)
+ alf = 0.D0
+ IF (v2==0.D0) THEN
+ alf = 0.D0
+ ELSE
+ IF (de>0.D0) THEN
+ p2 = v2/de
+ alf = alfa(p2)
+ ELSE
+ IF (v2<0.D0) alf = -1.D0
+ IF (v2>0.D0) alf = 1.D0
+ END IF
+ END IF
+
+ b(i,j,k,ismpl) = (de+(1.D0+alf)*v2)/dely(j)
+ d(i,j,k,ismpl) = d(i,j,k,ismpl) - &
+ (de-(1.D0-alf)*v2)/dely(j)
+ END IF
+ END IF
+
+ IF (k0>1) THEN
+
+ IF (k<k0) THEN
+
+ de = dk(i,j,k,spec,ismpl)
+ v2 = 0.5D0*vz(i,j,k,ismpl)
+ alf = 0.D0
+ IF (v2==0.D0) THEN
+ alf = 0.D0
+ ELSE
+ IF (de>0.D0) THEN
+ p2 = v2/de
+ alf = alfa(p2)
+ ELSE
+ IF (v2<0.D0) alf = -1.D0
+ IF (v2>0.D0) alf = 1.D0
+ END IF
+ END IF
+
+ g(i,j,k,ismpl) = (de-(1.D0-alf)*v2)/delz(k)
+ d(i,j,k,ismpl) = d(i,j,k,ismpl) - &
+ (de+(1.D0+alf)*v2)/delz(k)
+ END IF
+
+ IF (k>1) THEN
+
+ de = dk(i,j,k-1,spec,ismpl)
+ v2 = 0.5D0*vz(i,j,k-1,ismpl)
+ alf = 0.D0
+ IF (v2==0.D0) THEN
+ alf = 0.D0
+ ELSE
+ IF (de>0.D0) THEN
+ p2 = v2/de
+ alf = alfa(p2)
+ ELSE
+ IF (v2<0.D0) alf = -1.D0
+ IF (v2>0.D0) alf = 1.D0
+ END IF
+ END IF
+
+ a(i,j,k,ismpl) = (de+(1.D0+alf)*v2)/delz(k)
+ d(i,j,k,ismpl) = d(i,j,k,ismpl) - &
+ (de-(1.D0-alf)*v2)/delz(k)
+
+ END IF
+
+ END IF
+
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+
+ RETURN
+ END
+
+!> @brief coefficents for the transport equation (here only the right side)
+!> @param[in] spec species index
+!> @param[in] ismpl local sample index
+!> @details
+!> calculate coefficents for the transport equation\n
+!> coefficients are stored as vectors in the diagonals a-g (d center) and rhs in w.\n
+ SUBROUTINE set_ccoefrs(spec,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_conc
+ use mod_time
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+
+ ! DOUBLE PRECISION rhoceff
+ DOUBLE PRECISION deltt
+ ! INTEGER c1, c2, c3, c4
+ INTEGER spec
+ DOUBLE PRECISION deltat, por
+ EXTERNAL deltat, por
+
+
+ deltt = deltat(simtime(ismpl),ismpl)
+
+! - - rhs: sources, also terms for transient calculations - - - - - - - - -
+
+ IF (transient .AND. tr_switch(ismpl)) THEN
+
+! - - - - - - - transient - - - - - - - - - - - - - - - - - - - - - - - - -
+ CALL omp_mvp(i0,j0,k0,concold(1,spec,cgen_time,ismpl), &
+ x(1,1,1,ismpl),a(1,1,1,ismpl),b(1,1,1,ismpl), &
+ c(1,1,1,ismpl),d(1,1,1,ismpl),e(1,1,1,ismpl), &
+ f(1,1,1,ismpl),g(1,1,1,ismpl))
+
+!$OMP do schedule(static) collapse(3)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+
+ d(i,j,k,ismpl) = d(i,j,k,ismpl) - &
+ por(i,j,k,ismpl)/(deltt*thetac)
+ w(i,j,k,ismpl) = w(i,j,k,ismpl) - &
+ por(i,j,k,ismpl)*concold(i+(j-1)*i0+(k-1)*i0*j0, &
+ spec,cgen_time,ismpl)/deltt - &
+ (1.D0-thetac)*x(i,j,k,ismpl)
+ w(i,j,k,ismpl) = w(i,j,k,ismpl)/thetac
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+
+ ELSE
+
+! - - - - - - - - steady state - - - - - - - - - - - - - - - - - - - - -
+! C$OMP do schedule(static) collapse(3)
+! do k=1,k0
+! do j=1,j0
+! do i=1,i0
+! w(i,j,k,ismpl) = w(i,j,k,ismpl)
+! - hs(i,j,k,spec,ismpl)
+! end do
+! end do
+! end do
+! C$OMP end do nowait
+ END IF
+
+ RETURN
+ END
diff --git a/forward/conc/set_cq.f90 b/forward/conc/set_cq.f90
new file mode 100644
index 0000000..b80014c
--- /dev/null
+++ b/forward/conc/set_cq.f90
@@ -0,0 +1,66 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief modify coefficents for a concentration equation according to the prescribed sources and sinks
+!> @param[in] spec species index
+!> @param[in] ismpl local sample index
+!> @details
+!> modify coefficents for a concentration equation according to the prescribed sources and sinks.\n
+!> coefficients are stored as vectors in the diagonals a-g (d center) and rhs in w.\n
+ SUBROUTINE set_cq(spec,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_time
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ INTEGER spec
+ DOUBLE PRECISION deltat, deltf, qc
+ EXTERNAL deltat, qc
+
+! rhs: sources
+ IF (transient .AND. tr_switch(ismpl)) THEN
+ deltf = deltat(simtime(ismpl),ismpl)
+!$OMP do schedule (static)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ w(i,j,k,ismpl) = w(i,j,k,ismpl) - qc(i,j,k,spec,ismpl)
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+ ELSE
+!$OMP do schedule (static)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ w(i,j,k,ismpl) = w(i,j,k,ismpl) - qc(i,j,k,spec,ismpl)
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+ END IF
+
+ RETURN
+ END
diff --git a/forward/converged.f90 b/forward/converged.f90
new file mode 100644
index 0000000..821aa45
--- /dev/null
+++ b/forward/converged.f90
@@ -0,0 +1,157 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief compute average for break condition
+!> @param[in] enough test for break
+!> @param[in] depsilon break condition
+!> @param[in] Htype history (number)
+!> @param[in] maxhistlen max history length
+!> @param[in] history HISTORY buffer
+!> @param[in] hlen History Length
+!> @param[in] ipos Position Index
+!> @param[in] Hmax history length
+!> @return "true" when converged
+!> @details
+!> proof "enough" < "depsilon" or the average of the last "hlen" steps\n
+ LOGICAL FUNCTION converged(enough,depsilon,htype,maxhistlen,hmax,history,hlen,ipos)
+
+ USE mod_genrl
+ use mod_linfos
+
+ IMPLICIT NONE
+
+ ! step diff. or precision
+ DOUBLE PRECISION enough
+
+ ! break condition
+ DOUBLE PRECISION depsilon
+
+ ! max history length
+ INTEGER maxhistlen
+
+ ! number of probes for each history length
+ INTEGER maxprob
+ PARAMETER (maxprob=4)
+
+ ! History (selection, counter, number)
+ INTEGER htype, h, hmax
+
+ ! HISTORY buffer
+ DOUBLE PRECISION history(maxhistlen,hmax)
+
+ ! History Length
+ INTEGER hlen(hmax)
+
+ ! Position Index
+ INTEGER ipos(hmax)
+
+ ! locale SUM for average computation
+ DOUBLE PRECISION lsum, smin, smax
+
+ ! loop Index
+ INTEGER i
+
+ ! Wrong htype values
+ IF (htype==0) THEN
+ WRITE(*,*) &
+ 'error: "history type"=0 in "converged" not allowed !'
+ STOP
+ END IF
+ IF (htype>hmax) THEN
+ WRITE(*,*) 'error: "history number" (Hmax<', htype, &
+ ') in "converged" to low !'
+ STOP
+ END IF
+
+ ! nonlinear convergence test is disabled by input file
+ IF (.NOT. nlconverge .eq. 0) THEN
+ converged = .FALSE.
+ RETURN
+ END IF
+
+ ! quick test: maximum difference smaller than tolerance
+ IF (abs(enough)<depsilon) THEN
+ converged = .TRUE.
+ RETURN
+ END IF
+
+ ! set defaults
+ converged = .FALSE.
+ h = htype
+ IF (htype<0) THEN
+ ! init iterations, then end
+ h = -htype
+ hlen(h) = 1
+ ipos(h) = -1
+ RETURN
+ END IF
+
+ ! break, if history buffer too small
+ IF (ipos(h)>=maxprob*maxhistlen) THEN
+ WRITE(*,*) 'warning: history buffer in "converged.f"', &
+ ' to small ! <break outer iterations>'
+ converged = .TRUE.
+ END IF
+
+ ! fill history with new element
+ IF (ipos(h)>=maxprob*hlen(h)) THEN
+
+ ! increase history length
+ hlen(h) = hlen(h) + 1
+ ipos(h) = -1
+ history(hlen(h),h) = enough
+
+ ELSE
+
+ ! Add position
+ ipos(h) = ipos(h) + 1
+ history(1+mod(ipos(h),hlen(h)),h) = enough
+
+ END IF
+
+ ! compute sum for average
+ lsum = 0.0D0
+ smin = history(1,h)
+ smax = history(1,h)
+ DO i = 1, hlen(h)
+ lsum = lsum + history(i,h)
+ smin = min(smin,history(i,h))
+ smax = max(smax,history(i,h))
+ END DO
+
+! can we break iterations (enough precision)
+ IF ((abs(lsum)/dble(hlen(h)))<depsilon) converged = .TRUE.
+
+ IF ((abs(enough)>depsilon) .AND. (converged)) THEN
+ IF (h==1) WRITE(*,'(2(A,1e15.8),A,I3)') &
+ 'warning: oscillating convergence in HEAD, [min:max] = [', &
+ smin, ':', smax, '], period length=', hlen(h)
+ IF (h==2) WRITE(*,'(2(A,1e15.8),A,I3)') &
+ 'warning: oscillating convergence in TEMP, [min:max] = [', &
+ smin, ':', smax, '], period length=', hlen(h)
+ IF (h>=4) WRITE(*,'(2(A,1e15.8),A,I3)') &
+ 'warning: oscillating convergence in CONC, [min:max] = [', &
+ smin, ':', smax, '], period length=', hlen(h)
+ END IF
+
+ RETURN
+ END
diff --git a/forward/courant.f90 b/forward/courant.f90
new file mode 100644
index 0000000..0f414a1
--- /dev/null
+++ b/forward/courant.f90
@@ -0,0 +1,200 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief OpenMP wrapper for "omp_courant"
+!> @param[out] courant_max global courant number
+!> @param[in] ismpl local sample index
+ SUBROUTINE courant(courant_max,ismpl)
+ use mod_genrl
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+ DOUBLE PRECISION courant_max
+ integer :: ismpl
+
+#ifdef fOMP
+!$OMP parallel num_threads(Tlevel_1)
+!$ call omp_binding(ismpl)
+#endif
+ CALL omp_courant(courant_max,ismpl)
+#ifdef fOMP
+!$OMP end parallel
+#endif
+
+ RETURN
+ END
+
+!> @brief calculate grid courant number
+!> @param[out] courant_max global courant number
+!> @param[in] ismpl local sample index
+ SUBROUTINE omp_courant(courant_max,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_temp
+ use mod_time
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: i, j, k
+ integer :: ismpl
+
+ DOUBLE PRECISION courant_maxx, courant_minx, courant_avgx
+ DOUBLE PRECISION courant_maxy, courant_miny, courant_avgy, courant_maxz
+ DOUBLE PRECISION courant_minz, courant_avgz
+ DOUBLE PRECISION courant_max, fac, delt, deltat, davg, val, min_veloc
+ EXTERNAL deltat
+! min. value, ignore courant numbers for lower velocities
+ PARAMETER (min_veloc=1.0D-10)
+!
+ INTEGER c1, c2, c3
+ DOUBLE PRECISION vx, vy, vz, por
+ EXTERNAL vx, vy, vz, por
+
+ delt = deltat(simtime(ismpl),ismpl)
+!
+ IF ( .NOT. (transient .AND. tr_switch(ismpl))) THEN
+!$OMP master
+ WRITE(*,*) ' courant: not defined for steady state'
+!$OMP end master
+ RETURN
+ END IF
+!
+ c1 = 0
+ courant_maxx = small
+ courant_minx = big
+ courant_avgx = 0.0D0
+!$OMP do schedule(static)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 2, i0 - 1
+ val = abs(vx(i,j,k,ismpl))
+ IF (val>=min_veloc) THEN
+ c1 = c1 + 1
+ davg = 0.5D0*(delx(i)+delx(i+1))
+ fac = delt/(davg*por(i,j,k,ismpl))
+ val = val*fac
+ IF (val>courant_maxx) courant_maxx = val
+ IF (val<courant_minx) courant_minx = val
+ courant_avgx = courant_avgx + val
+ END IF
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+!
+ c2 = 0
+ courant_maxy = small
+ courant_miny = big
+ courant_avgy = 0.0D0
+!$OMP do schedule(static)
+ DO k = 1, k0
+ DO j = 2, j0 - 1
+ DO i = 1, i0
+ val = abs(vy(i,j,k,ismpl))
+ IF (val>=min_veloc) THEN
+ c2 = c2 + 1
+ davg = 0.5D0*(dely(j)+dely(j+1))
+ fac = delt/(davg*por(i,j,k,ismpl))
+ val = val*fac
+ IF (val>courant_maxy) courant_maxy = val
+ IF (val<courant_miny) courant_miny = val
+ courant_avgy = courant_avgy + val
+ END IF
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+!
+ c3 = 0
+ courant_maxz = small
+ courant_minz = big
+ courant_avgz = 0.0D0
+!$OMP do schedule(static)
+ DO k = 2, k0 - 1
+ DO j = 1, j0
+ DO i = 1, i0
+ val = abs(vz(i,j,k,ismpl))
+ IF (val>=min_veloc) THEN
+ c3 = c3 + 1
+ davg = 0.5D0*(delz(k)+delz(k+1))
+ fac = delt/(davg*por(i,j,k,ismpl))
+ val = val*fac
+ IF (val>courant_maxz) courant_maxz = val
+ IF (val<courant_minz) courant_minz = val
+ courant_avgz = courant_avgz + val
+ END IF
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+!
+! compute global sum for all values
+ CALL omp_summe(courant_maxx,courant_minx,courant_avgx, &
+ courant_maxy,courant_miny,courant_avgy,courant_maxz, &
+ courant_minz,courant_avgz,c1,c2,c3,ismpl)
+!
+!$OMP master
+ IF (i0>2) THEN
+ courant_avgx = courant_avgx/dble(c1)
+ ELSE
+ courant_maxx = 0.0D0
+ courant_minx = 0.0D0
+ courant_avgx = 0.0D0
+ END IF
+ IF (j0>2) THEN
+ courant_avgy = courant_avgy/dble(c2)
+ ELSE
+ courant_maxy = 0.0D0
+ courant_miny = 0.0D0
+ courant_avgy = 0.0D0
+ END IF
+ IF (k0>2) THEN
+ courant_avgz = courant_avgz/dble(c3)
+ ELSE
+ courant_maxz = 0.0D0
+ courant_minz = 0.0D0
+ courant_avgz = 0.0D0
+ END IF
+!
+ courant_max = max(courant_maxx,courant_maxy,courant_maxz)
+!
+ IF (linfos(3)>=2) THEN
+ WRITE(*,*) 'courant-number in x,y,z:'
+ WRITE(*,'(a,1e10.3,a,1e10.3,a,1e10.3)') ' max. : ', &
+ courant_maxx, ', ', courant_maxy, ', ', courant_maxz
+ WRITE(*,'(a,1e10.3,a,1e10.3,a,1e10.3)') ' min. : ', &
+ courant_minx, ', ', courant_miny, ', ', courant_minz
+ WRITE(*,'(a,1e10.3,a,1e10.3,a,1e10.3,1a,3I8)') ' avg. : ', &
+ courant_avgx, ', ', courant_avgy, ', ', &
+ courant_avgz, ', #', c1, c2, c3
+ END IF
+!
+ IF (linfos(3)>=1 .AND. courant_max>1.D0) THEN
+ WRITE(*,'(a)') '!!!: courant number(s) greater than 1 :'
+ WRITE(*,'(a,1e12.3,a,1e10.3,a,1e10.3)') 'x: ', &
+ courant_maxx, 'y: ', courant_maxy, 'z: ', courant_maxz
+ WRITE(*,*)
+ END IF
+!$OMP end master
+
+ RETURN
+ END
diff --git a/forward/ctrlut/decntrl3.f90 b/forward/ctrlut/decntrl3.f90
new file mode 100644
index 0000000..1defefc
--- /dev/null
+++ b/forward/ctrlut/decntrl3.f90
@@ -0,0 +1,45 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief convert the number code ctrl0 (12bit) into 3 discrete numbers c1,c2,c3 (each 4bit)
+!> @param[in] ctrl0 number code
+!> @param[out] c1 first discrete value
+!> @param[out] c2 second discrete value
+!> @param[out] c3 third discrete value
+!> @details
+!> decode [ctrl]\n
+!> ctrl = c1 + 16*c2 + 256*c3\n
+ SUBROUTINE decntrl3(ctrl0,c1,c2,c3)
+ IMPLICIT NONE
+ INTEGER ctrl, ctrl0, c1, c2, c3
+!
+ ctrl = ctrl0
+ c1 = mod(ctrl,16)
+!
+ ctrl = ctrl/16
+ c2 = mod(ctrl,16)
+!
+ ctrl = ctrl/16
+ c3 = mod(ctrl,16)
+!
+ RETURN
+ END
diff --git a/forward/ctrlut/decntrl4.f90 b/forward/ctrlut/decntrl4.f90
new file mode 100644
index 0000000..c45c3c0
--- /dev/null
+++ b/forward/ctrlut/decntrl4.f90
@@ -0,0 +1,49 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief convert the number code ctrl0 (16bit) into 4 discrete numbers c1,c2,c3,c4 (each 4bit)
+!> @param[in] ctrl0 number code
+!> @param[out] c1 first discrete value
+!> @param[out] c2 second discrete value
+!> @param[out] c3 third discrete value
+!> @param[out] c4 fourth discrete value
+!> @details
+!> decode [ctrl]\n
+!> ctrl = c1 + 16*c2 + 256*c3 + 4096*c4\n
+ SUBROUTINE decntrl4(ctrl0,c1,c2,c3,c4)
+ IMPLICIT NONE
+ INTEGER ctrl, ctrl0, c1, c2, c3, c4
+!
+ ctrl = ctrl0
+ c1 = mod(ctrl,16)
+!
+ ctrl = ctrl/16
+ c2 = mod(ctrl,16)
+!
+ ctrl = ctrl/16
+ c3 = mod(ctrl,16)
+!
+ ctrl = ctrl/16
+ c4 = mod(ctrl,16)
+!
+ RETURN
+ END
diff --git a/forward/ctrlut/encntrl3.f90 b/forward/ctrlut/encntrl3.f90
new file mode 100644
index 0000000..b1fabd5
--- /dev/null
+++ b/forward/ctrlut/encntrl3.f90
@@ -0,0 +1,35 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief convert 3 discrete numbers c1,c2,c3 (each 4bit) into the number code ctrl0 (12bit)
+!> @param[out] ctrl number code
+!> @param[in] c1 first discrete value
+!> @param[in] c2 second discrete value
+!> @param[in] c3 third discrete value
+ SUBROUTINE encntrl3(ctrl,c1,c2,c3)
+ IMPLICIT NONE
+ INTEGER ctrl, c1, c2, c3
+!
+ ctrl = c1 + 16*c2 + 256*c3
+!
+ RETURN
+ END
diff --git a/forward/ctrlut/encntrl4.f90 b/forward/ctrlut/encntrl4.f90
new file mode 100644
index 0000000..1eefb1c
--- /dev/null
+++ b/forward/ctrlut/encntrl4.f90
@@ -0,0 +1,36 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief convert 4 discrete numbers c1,c2,c3,c4 (each 4bit) into the number code ctrl0 (16bit)
+!> @param[out] ctrl number code
+!> @param[in] c1 first discrete value
+!> @param[in] c2 second discrete value
+!> @param[in] c3 third discrete value
+!> @param[in] c4 fourth discrete value
+ SUBROUTINE encntrl4(ctrl,c1,c2,c3,c4)
+ IMPLICIT NONE
+ INTEGER ctrl, c1, c2, c3, c4
+!
+ ctrl = c1 + 16*c2 + 256*c3 + 4096*c4
+!
+ RETURN
+ END
diff --git a/forward/ctrlut/ijk_m.f90 b/forward/ctrlut/ijk_m.f90
new file mode 100644
index 0000000..05a0ee3
--- /dev/null
+++ b/forward/ctrlut/ijk_m.f90
@@ -0,0 +1,91 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief compute "i,j,k"-index of "m", depending on "i0,j0,k0"
+!> @param[in] m continuous memory cell-index
+!> @param[out] i cell index, direction I0
+!> @param[out] j cell index, direction J0
+!> @param[out] k cell index, direction K0
+!> @details
+!> Compute k cell index: \n\n
+!>
+!> k = (m-1) / (i0*j0) + 1 \n\n
+!>
+!> Explanations:\n
+!> 1) m-1: The integer steps between k-indices are at elements m =
+!> n*(i0*j0 + 1) for some positive integer n [f.e.: m=i0*j0 is
+!> still in the lowest layer, m=i0*j0+1 is in the second lowest
+!> layer]. The steps of the division are at m_div = n*(i0*j0). \n
+!> 2) +1 at end: The division gives k = 0 for the lowest layer, k = 1
+!> for the second-lowest, and so on. The layer-counting starts at
+!> k=1, so 1 is added. \n\n
+!>
+!> Compute j cell index: \n\n
+!>
+!> j = (m-1 - (k-1)*i0*j0) / i0 + 1 \n\n
+!>
+!> Explanations:\n
+!> 1) (m-1 - (k-1)*i0*j0): The index is projected onto its
+!> partner-index on the lowest layer by subtracting the number of
+!> z-layers on top, then one is subtracted, since the steps between
+!> j-indices should be at m=n*(i0+1), but the steps of the division
+!> by i0 are at m=n*i0. \n
+!> 2) +1 at end: The division by i0 gives j = 0 for the first line in
+!> x-direction, j = 1 for the second, and so on. The line-counting
+!> should start at j=1, so 1 is added. \n\n
+!>
+!> Compute i cell index: \n\n
+!>
+!> i = m - (k-1)*i0*j0 - (j-1)*i0\n\n
+!>
+!> Explanations:\n
+!> 1) (m - (k-1)*i0*j0): The index is projected onto its
+!> partner-index on the lowest layer by subtracting the number of
+!> z-layers on top. \n
+!> 2) - (j-1)*i0: The index is projected onto its
+!> partner-index on the first line by subtracting the number of
+!> y-lines . \n\n
+ subroutine ijk_m(m,i,j,k)
+
+ use mod_genrl, only: i0, j0, k0
+
+ implicit none
+
+ ! Continuous linear index
+ integer, intent (in) :: m
+
+ ! i-cell/j-cell/k-cell index
+ integer, intent (out) :: i, j, k
+
+
+ ! Compute k-cell index
+ k = (m-1) / (i0*j0) + 1
+
+ ! Compute j-cell index
+ j = (m-1 - (k-1)*i0*j0) / i0 + 1
+
+ ! Compute i-cell index
+ i = m - (k-1)*i0*j0 - (j-1)*i0
+
+ return
+
+ end subroutine ijk_m
diff --git a/forward/ctrlut/m_ijk.f90 b/forward/ctrlut/m_ijk.f90
new file mode 100644
index 0000000..fafb7cf
--- /dev/null
+++ b/forward/ctrlut/m_ijk.f90
@@ -0,0 +1,36 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief compute "m" of "i,j,k"-index, depending on "i0,j0,k0"
+!> @param[out] m continuous memory cell-index
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+ SUBROUTINE m_ijk(i,j,k,m)
+ use mod_genrl
+ IMPLICIT NONE
+ integer :: i, j, k, m
+!
+ m = i+(j-1)*i0+(k-1)*i0*j0
+!
+ RETURN
+ END
diff --git a/forward/dealloc_arrays.f90 b/forward/dealloc_arrays.f90
new file mode 100644
index 0000000..cf0cc7c
--- /dev/null
+++ b/forward/dealloc_arrays.f90
@@ -0,0 +1,245 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief free the memory of all global main arrays (with dynamic size)
+!> @param[in] ismpl local sample index
+ SUBROUTINE dealloc_arrays(ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_data
+ use mod_time
+ use mod_conc
+ use mod_linfos
+ use mod_OMP_TOOLS
+ use mod_blocking_size
+ IMPLICIT NONE
+ integer :: ismpl
+ INCLUDE 'OMP_TOOLS.inc'
+ INTEGER mfactor
+ INTRINSIC max
+
+!
+ IF (linfos(1)>=2) WRITE(*,*) ' [I] : ... dealloc_arrays'
+!
+! single system size (factor == 1)
+ mfactor = 1
+
+ DEALLOCATE(project_sfx)
+
+ DEALLOCATE(propunit)
+ memory = memory - nunits*nprop*nsmpl
+
+! temporary convergence list
+ DEALLOCATE(conc_conv)
+ memory = memory - ntrac*nsmpl
+
+ DEALLOCATE(node_info)
+ memory = memory - i0*j0*k0
+! additional global & private vectors for linear system solver
+! global buffer for boundary exchange (+ismpl)
+ DEALLOCATE(lss_bound_block)
+ memory = memory - (block_i*block_j+block_i*block_k+block_j*block_k)*bdim_i*bdim_j*bdim_k*2*nsmpl
+ DEALLOCATE(lss_dnrm)
+ memory = memory - i0*j0*k0*nsmpl
+ DEALLOCATE(lss_tmp)
+ memory = memory - i0*j0*k0*nsmpl
+! private copy for preconditioning (+Tlevel_1 +ismpl)
+ DEALLOCATE(lss_lma)
+ memory = memory - max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
+ DEALLOCATE(lss_lmb)
+ memory = memory - max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
+ DEALLOCATE(lss_lmc)
+ memory = memory - max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
+ DEALLOCATE(lss_lmd)
+ memory = memory - max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
+ DEALLOCATE(lss_lme)
+ memory = memory - max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
+ DEALLOCATE(lss_lmf)
+ memory = memory - max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
+ DEALLOCATE(lss_lmg)
+ memory = memory - max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
+ DEALLOCATE(lss_lud)
+ memory = memory - max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
+ DEALLOCATE(lss_lx)
+ memory = memory - max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
+ DEALLOCATE(lss_lb)
+ memory = memory - max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
+!
+ DEALLOCATE(lss_lloctmp)
+ memory = memory - max_blocks*block_i*block_j*block_k*mfactor*max_loctmp*tlevel_1*nsmpl
+!
+ DEALLOCATE(lss_ldnrm)
+ memory = memory - max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
+ DEALLOCATE(lss_ud_block)
+ memory = memory - (block_i*block_j+block_i*block_k+block_j*block_k)*max_blocks*tlevel_1*nsmpl
+ DEALLOCATE(lss_lr0_hat)
+ memory = memory - max_blocks*block_i*block_j*block_k*tlevel_1*nsmpl
+
+! variables for variable time stepping
+ deallocate(flag_delt)
+ memory = memory - nsmpl
+ deallocate(delt_count)
+ memory = memory - nsmpl
+ deallocate(flag_1st_timestep)
+ memory = memory - nsmpl
+ deallocate(delt_old)
+ memory = memory - nsmpl
+!
+!
+! coefficients for linear equations
+ DEALLOCATE(a)
+ memory = memory - i0*j0*k0*mfactor*nsmpl
+ DEALLOCATE(b)
+ memory = memory - i0*j0*k0*mfactor*nsmpl
+ DEALLOCATE(c)
+ memory = memory - i0*j0*k0*mfactor*nsmpl
+ DEALLOCATE(d)
+ memory = memory - i0*j0*k0*mfactor*nsmpl
+ DEALLOCATE(e)
+ memory = memory - i0*j0*k0*mfactor*nsmpl
+ DEALLOCATE(f)
+ memory = memory - i0*j0*k0*mfactor*nsmpl
+ DEALLOCATE(g)
+ memory = memory - i0*j0*k0*mfactor*nsmpl
+ DEALLOCATE(x)
+ memory = memory - i0*j0*k0*mfactor*nsmpl
+!
+ DEALLOCATE(w)
+ memory = memory - i0*j0*k0*mfactor*nsmpl
+ DEALLOCATE(r)
+ memory = memory - i0*j0*k0*mfactor
+ DEALLOCATE(bc_mask)
+ memory = memory - i0*j0*k0*mfactor*nsmpl
+! only for ilu-precond. (shadow vectors)
+ DEALLOCATE(ud)
+ memory = memory - i0*j0*k0*mfactor*nsmpl
+!
+!
+ DEALLOCATE(head)
+ memory = memory - i0*j0*k0*nsmpl
+ DEALLOCATE(temp)
+ memory = memory - i0*j0*k0*nsmpl
+ DEALLOCATE(conc)
+ memory = memory - i0*j0*k0*max(ntrans,1)*nsmpl
+ DEALLOCATE(pres)
+ memory = memory - i0*j0*k0*nsmpl
+ DEALLOCATE(tsal)
+ memory = memory - i0*j0*k0*nsmpl
+ DEALLOCATE(uindex)
+ memory = memory - i0*j0*k0
+
+ DEALLOCATE(headold)
+ memory = memory - i0*j0*k0*ncgen*nsmpl
+ DEALLOCATE(tempold)
+ memory = memory - i0*j0*k0*ncgen*nsmpl
+ DEALLOCATE(concold)
+ memory = memory - i0*j0*k0*ncgen*nsmpl*max(ntrans,1)
+ DEALLOCATE(presold)
+ memory = memory - i0*j0*k0*ncgen*nsmpl
+
+ DEALLOCATE(delx)
+ memory = memory - i0
+ DEALLOCATE(dely)
+ memory = memory - j0
+ DEALLOCATE(delz)
+ memory = memory - k0
+ DEALLOCATE(delxa)
+ memory = memory - i0
+ DEALLOCATE(delya)
+ memory = memory - j0
+ DEALLOCATE(delza)
+ memory = memory - k0
+
+ if (vdefaultswitch) then
+ DEALLOCATE(vdefault)
+ end if
+
+! dealloc. proz. grid array, see more in 'solve/omp_preconditioniers.f'
+ CALL par_end2()
+
+! time periods
+ DEALLOCATE(bcperiod)
+ memory = memory - ngsmax*3*max(nbctp,1)*nsmpl
+ DEALLOCATE(ibcperiod)
+ memory = memory - max(nbctp,1)
+ DEALLOCATE(lbcperiod)
+ memory = memory - ngsmax*max(nbctp,1)
+ DEALLOCATE(outt)
+ memory = memory - max(noutt+1,1)
+ DEALLOCATE(smon_idx)
+ memory = memory - nsmpl
+ deallocate(delta_time)
+ memory = memory - max(ntimestep,1)
+
+ DEALLOCATE(simtime)
+ memory = memory - nsmpl
+
+ DEALLOCATE(tr_switch)
+ memory = memory - nsmpl
+
+ DEALLOCATE(fh_table)
+ memory = memory - c_fhandler*tlevel_0
+
+ DEALLOCATE(diff_c)
+ memory = memory - max(ntrans,1)
+ DEALLOCATE(mmas_c)
+ memory = memory - max(ntrans,1)
+ DEALLOCATE(beta_c)
+ memory = memory - max(ntrans,1)
+
+! boundary structures
+ DEALLOCATE(ibc_data)
+ memory = memory - max(nbc_data,1)*nibc
+ DEALLOCATE(dbc_data)
+ memory = memory - max(nbc_data,1)*ndbc*nsmpl
+ DEALLOCATE(dbc_dataold)
+ memory = memory - max(nbc_data,1)
+
+! borehole logs
+ DEALLOCATE(ibh_pos)
+ memory = memory - 2*nbh_logs
+ DEALLOCATE(cbh_name)
+ memory = memory - nbh_logs*64
+
+! - convergency history buffer -
+ DEALLOCATE(conv_history)
+ memory = memory - conv_hlen*conv_hmax*nsmpl
+ DEALLOCATE(conv_chlen)
+ DEALLOCATE(conv_ipos)
+ DEALLOCATE(lcon)
+ memory = memory - 3*conv_hmax*nsmpl
+
+#ifdef DEBUG
+ DEALLOCATE(debugout)
+ n_debugout = 0
+#endif
+
+! OpenMP specific REDUCTION staff
+ DEALLOCATE(omp_dglobal)
+ DEALLOCATE(omp_iglobal)
+ memory = memory - 12*tlevel_1*nsmpl
+
+
+ write(*,*) "Deallocated Memory, remaining ",memory*8/1024/1024, " MB"
+ RETURN
+ END SUBROUTINE dealloc_arrays
diff --git a/forward/deltat.f90 b/forward/deltat.f90
new file mode 100644
index 0000000..6347e45
--- /dev/null
+++ b/forward/deltat.f90
@@ -0,0 +1,220 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief get the size of the current time step
+!> @param[in] sim_time current simulation time
+!> @param[in] ismpl local sample index
+!> @return deltat of the time step
+!> @details
+!> Return the deltat of the time step depending on the simulation time
+!> [sim_time] and the time step table [delta_time]\n\n
+!>
+!> 1. Input time stepping: Add delta_time values until the cumulative
+!> sum minus 1/100 times the last deltat is larger than the simulation
+!> time input. Then, the final deltat is the output of the
+!> function. \n\n
+!>
+!> 2. Variable time stepping: Set (a) the starting time step in the
+!> beginning, (b) go back to the last simtime and half the previous
+!> time step, when the nonlinear maxiter was reached, or (c) keep the
+!> time step or double it if everything was alright, then look for the
+!> maximum simulation time or upcoming output times and adjust the
+!> time step accordingly.
+ double precision function deltat(sim_time,ismpl)
+
+ use arrays, only: delta_time, flag_1st_timestep, delt_count, &
+ delt_old, flag_delt, simtime, outt
+ use mod_genrl, only: delt_double, delt_min, delt_max, delt_start, &
+ delt_vary
+ use mod_time, only: max_simtime, simtime_0, noutt, ntimestep
+
+ implicit none
+
+ double precision, intent (in) :: sim_time
+
+ integer :: ismpl
+
+ ! Counter
+ integer :: i
+
+ ! Tolerance for sim_time smaller timesum
+ double precision :: tentol
+
+ ! Cumulative sum of delta_time values
+ double precision :: timesum
+
+ ! Time step counter
+ integer :: it
+
+ ! Output time id
+ integer :: id
+
+ if (.not. delt_vary) then
+ ! Time stepping from `# time periods`
+ ! -----------------------------------
+
+ deltat = 0.0d0
+
+ ! time step counter
+ it = 1
+
+ ! init time step size
+ deltat = delta_time(it)
+
+ ! 1% numerical tolerance
+ tentol = 0.01d0*deltat
+
+ ! init time sum
+ timesum = simtime_0 + deltat
+!
+ do while (sim_time + tentol >= timesum .and. it < ntimestep)
+ it = it + 1
+ ! update time step size
+ deltat = delta_time(it)
+ ! 1% numerical tolerance
+ tentol = 0.01d0*deltat
+ ! update time sum
+ timesum = timesum + deltat
+ end do
+
+ else
+ ! Variable time stepping.
+ ! -----------------------
+
+ if (sim_time == simtime_0 .and. flag_1st_timestep(ismpl) == 0) then
+
+ ! Set starting time step
+ deltat = delt_start
+ delt_old(ismpl) = deltat
+ delt_count(ismpl) = 0
+
+ else
+
+ ! Set previous time step
+ deltat = delt_old(ismpl)
+
+ end if
+
+ if (flag_delt(ismpl) == -2) then
+ ! Iterative solver or Picard/Newton iteration reached maxiter
+
+ !Restore old simulation time
+ simtime(ismpl) = simtime(ismpl) - delt_old(ismpl)
+
+ flag_1st_timestep(ismpl) = 1
+
+ write(*,*) "Halfing time step!"
+ write(*,*) "Old deltat: ", deltat
+
+ ! Half the time step size
+ deltat = 0.5*deltat
+
+ write(*,*) "New deltat: ", deltat
+
+ ! Check whether minimum deltat is reached
+ if (deltat < delt_min) then
+ write(*,*) "Minimum step size reached. Aborting."
+ write(unit = *, fmt = *) "Current deltat = ", deltat
+ write(unit = *, fmt = *) "Minimum deltat = ", delt_min
+ stop
+ end if
+
+ else if (flag_delt(ismpl) == 1) then
+ ! Iterative solver or Picard/Newton iteration fine
+
+ ! Counter closer to doubling
+ delt_count(ismpl) = delt_count(ismpl) + 1
+
+ ! Doubling time step size if delt_count hits delt_double
+ if (delt_count(ismpl) == delt_double) then
+
+ ! Reset doubling counter
+ delt_count(ismpl) = 0
+
+ write(*,*) "Doubling time step size!"
+ write(*,*) "Old deltat: ", deltat
+
+ ! Double the time step size.
+ deltat = 2*deltat
+
+ write(*,*) "New deltat: ", deltat
+
+ ! Check whether maximum delt is reached
+ if (deltat > delt_max) then
+ write(*,*) "Maximum deltat reached. No further timestep size increase possible."
+ deltat = delt_max
+ write(*,*) "deltat: ", deltat
+ write(*,*) "delt_max: ", delt_max
+ end if
+ end if
+
+ ! Is max_simtime reached?
+ ! Info: add delt_old, because simtime update not yet realized
+ if ((simtime(ismpl) + delt_old(ismpl) + deltat) > max_simtime) then
+ write(*,*) "Changing step size to reach simulation end."
+
+ ! Set deltat to reach max_simtime
+ deltat = max_simtime - simtime(ismpl)-delt_old(ismpl)
+
+ write(*,*) "deltat: ", deltat
+
+ end if
+
+ ! Find the upcoming output time id
+ id = 0
+ do i = 1, noutt +1
+
+ if (outt(i) > simtime(ismpl) + delt_old(ismpl) ) then
+
+ id = i
+ exit
+
+ end if
+
+ end do
+
+ ! Change deltat to match output time if output time is in
+ ! the next time step.
+ if ((simtime(ismpl) + delt_old(ismpl) + deltat) > outt(id)) then
+
+ ! Match only if the new deltat is larger than 10 times
+ ! the minimum step size
+ if ((outt(id) - simtime(ismpl) - delt_old(ismpl)) > 10.0d0*delt_min) then
+
+ deltat = outt(id) - simtime(ismpl) - delt_old(ismpl)
+
+ write(*,*) "Changing deltat to match output time."
+ write(*,*) "deltat: ", deltat
+
+ end if
+
+ end if
+
+ end if
+
+ delt_old(ismpl) = deltat
+
+ end if
+
+ return
+
+ end function deltat
diff --git a/forward/forward_init.f90 b/forward/forward_init.f90
new file mode 100644
index 0000000..bc64a6f
--- /dev/null
+++ b/forward/forward_init.f90
@@ -0,0 +1,78 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief forward model initialisation
+!> @param[in] ismpl local sample index
+!> @details
+!> - For the head-based model computation, the pressure may need to be
+!> computed from head input. For the pres-based model computation,
+!> the head may need to be computed from pressure input. \n\n
+!>
+!> - Call user and props initializing subroutines \n\n
+!>
+!> - output memory information\n
+ subroutine forward_init(ismpl)
+
+ use mod_genrl, only: is_init_flow_trafo_needed, memory
+ use mod_linfos, only: linfos
+
+ implicit none
+
+ ! Local sample index
+ integer :: ismpl
+
+ ! Local variable for array memory
+ double precision :: memloc
+
+
+ if (linfos(3)>=2) write(*,*) ' ... forward_init'
+
+ ! If needed: Transformation to non-computed flow variable.
+#ifdef head_base
+ if (is_init_flow_trafo_needed) call head2pres(0,ismpl)
+#endif
+#ifdef pres_base
+ if (is_init_flow_trafo_needed) call pres2head(0,ismpl)
+#endif
+
+ ! USER model init
+ call user_init(ismpl)
+
+ ! PROPS model init
+ call props_init(ismpl)
+
+ ! Memory information output
+ if (linfos(1)>=0) then
+ ! Assume double precision data type
+ memloc = memory*8.0D0
+ ! ... in KByte
+ memloc = memloc/1024.0D0
+ ! ... in MByte
+ memloc = memloc/1024.0D0
+ write(*,*) ''
+ write(*,'(a,f11.3,a)') ' [I] : memory: ', memloc, ' MByte data'
+ write(*,*) ''
+ end if
+
+ return
+
+ end subroutine forward_init
diff --git a/forward/forward_iter.f90 b/forward/forward_iter.f90
new file mode 100644
index 0000000..86ccbee
--- /dev/null
+++ b/forward/forward_iter.f90
@@ -0,0 +1,210 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief time discretisation loop
+!> @param[in] simtime_run start time of the simulation
+!> @param[in] simtime_end finish time of the simulation
+!> @param[in] ismpl local sample index
+!> @details
+!> In-a-Nutshell description of this subroutine: \n
+!> - Preprocessing before time step loop, initial variable values,
+!> monitoring output, extra steady-state initialisation, status_log\n
+!> - Time loop: \n
+!> - before computations: time stepping, saving old variable arrays,
+!> output \n
+!> - computation: calling `forward_wrapper.f90`
+!> - after computations: save simulated data, update simtime,
+!> output, check divergence for variable step size \n
+!> - Postprocessing: standard output
+ subroutine forward_iter(simtime_run,simtime_end,ismpl)
+
+ use arrays, only: flag_1st_timestep, simtime, tr_switch, &
+ flag_delt
+ use mod_genrl, only: cgen_time, iter_nlold, maxiter_nl, runmode, &
+ write_iter_disable
+ use mod_genrlc, only: status_log
+ use mod_time, only: itimestep_0, max_simtime, monitor, simtime_0, &
+ transient, tunit
+ use mod_linfos, only: linfos
+
+ implicit none
+
+ ! local sample index
+ integer :: ismpl
+
+ ! Time step index
+ integer :: itimestep
+
+ ! Size of a time period
+ double precision :: deltt
+
+ ! Start time of the simulation
+ double precision, intent (in) :: simtime_run
+
+ ! Finish time of the simulation
+ double precision, intent (in) :: simtime_end
+
+ double precision, external :: deltat
+ integer, external :: lblank
+
+
+ ! Preprocessing
+ ! -------------
+
+ ! initial values for some variables/arrays
+ flag_1st_timestep(ismpl)=0
+ itimestep = itimestep_0
+ simtime(ismpl) = simtime_run
+ deltt = deltat(simtime(ismpl),ismpl)
+ tr_switch(ismpl) = .true.
+ iter_nlold = maxiter_nl/2
+
+ ! initial monitoring output
+ if (transient .and. monitor .and. simtime_run == simtime_0) then
+ call write_monitor(1,ismpl)
+ call write_monitor_user(1,ismpl)
+ end if
+
+ ! runmode 2: extra steady state initialisation
+ if (transient .and. runmode == 2) then
+
+ tr_switch(ismpl) = .false.
+ if (linfos(2) >= 0) write(*,'(1A)') ' [I] : extra steady state initialisation'
+
+ call forward_wrapper(itimestep,ismpl)
+
+ if (linfos(2) >= 0) write(*,'(1A)') ' [I] : normal transient process'
+ tr_switch(ismpl) = .true.
+
+ end if
+
+ ! Write to status_log
+ if (transient .and. (.not. write_iter_disable)) then
+
+ open(76, file=status_log, status='unknown', position='append')
+ write(76, fmt='(I8,1e14.6,1e14.6)') itimestep, deltt, simtime(ismpl)/tunit
+ close(76)
+
+ end if
+
+ ! Time step loop for forward modeling
+ ! -----------------------------------
+1000 CONTINUE
+
+ if (transient) then
+
+ ! Advance time step
+ itimestep = itimestep + 1
+
+ ! Initialize flag for variable time step size
+ flag_delt(ismpl) = 0
+
+ ! Time stepping info to standard out
+ if (linfos(1)>=1) then
+ write(*,*) ' '
+ write(*,'(1A,1I6)') ' >>>> new time step: ', itimestep
+ write(*,'(1A,1e16.8,1A,1e16.8)') ' >>>> cum. time= ', &
+ (simtime(ismpl)+deltt)/tunit, '/', max_simtime/tunit
+ write(*,'(1A,1e16.8)') ' >>>> time step= ', &
+ (deltt)/tunit
+
+ end if
+
+ ! Save old time level
+ call old_save(cgen_time,ismpl)
+
+ end if
+
+! ######### Forward Iteration ######
+ call forward_wrapper(itimestep,ismpl)
+! ##################################
+
+ ! save and collect the computed values for:
+ ! - comparison with 'ddata(*,cid_pv)' (observed data)
+ ! - data-output (write_data.f)
+ call save_data(ismpl)
+
+ if (transient) then
+
+ ! Update simulation time
+ simtime(ismpl) = simtime(ismpl) + deltt
+
+ ! wrapper for output
+ call write_outt(deltt,ismpl)
+
+ ! monitoring output
+ if (monitor .and. flag_delt(ismpl) /= -2) then
+ call write_monitor(2,ismpl)
+ call write_monitor_user(2,ismpl)
+ end if
+
+ ! Write to status_log
+ if ( .not. write_iter_disable) then
+
+ ! Status log info to standard out
+ if (linfos(1)>=1) then
+ write(*,'(3A)') ' [W] : "', status_log(1:lblank(status_log)), '"'
+ end if
+
+ open(76, file=status_log, status='unknown', position='append')
+ write(76, fmt='(I8,1e14.6,1e14.6)') itimestep, deltt, simtime(ismpl)/tunit
+ close(76)
+
+ end if
+
+ ! Check for variable time stepping divergence flag
+ if (flag_delt(ismpl) == -2) then
+ ! Restore old values of variable arrays if time step was
+ ! halfed (restoring simtime is handled in "deltat")
+ call old_restore(cgen_time, ismpl)
+ end if
+
+ ! Set variable time stepping divergence flag to zero to
+ ! avoid double calling of deltat.
+ flag_delt(ismpl) = 0
+ deltt = deltat(simtime(ismpl),ismpl)
+
+ end if
+
+ ! Important: This if statement (with the goto) needs to be
+ ! outside of the other "transient" scopes, to generate
+ ! reverse-mode code!
+ if (transient .and. simtime(ismpl) < simtime_end) go to 1000
+! --------------- 1000: return to next time step ----------------------
+
+ ! Postprocessing
+ ! --------------
+
+ ! Standard output: steady state
+ if (linfos(1) >= 1 .and. .not. transient) then
+ write(*,'(29X,1A)') ' ===> leaving nonlinear iteration'
+ end if
+
+ ! Standard output: transient
+ if (linfos(1) >= 0 .and. transient) then
+ write(*,'(1A,I8,1A,1e14.6)') ' [I] : final time step = ', &
+ itimestep,', simulation time', simtime(ismpl)/tunit
+ end if
+
+ return
+
+ end subroutine forward_iter
diff --git a/forward/forward_picard.f90 b/forward/forward_picard.f90
new file mode 100644
index 0000000..80c65f2
--- /dev/null
+++ b/forward/forward_picard.f90
@@ -0,0 +1,410 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief nonlinear picard iteration for flow, heat and transport equation
+!> @param[in] iter_time forward iteration counter
+!> @param[in] ismpl local sample index
+!> @details
+!> nonlinear iteration loop (convergency) for steady state and\n
+!> transient case (one time step)\n
+ SUBROUTINE forward_picard(iter_time,ismpl)
+
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_flow
+ use mod_temp
+ use mod_conc
+ use mod_time
+ use mod_data
+ use mod_linfos
+
+ IMPLICIT NONE
+
+ integer :: ismpl
+ integer :: i
+ integer :: iter_nl
+
+ ! Maximal difference and RMS-difference between old and new
+ ! variable array
+ double precision difmaxf, difrmsf
+ double precision difmaxt, difrmst
+ double precision difmaxc, difrmsc
+ double precision difmaxs, difrmss
+!
+ INTEGER ijk, mode, iter_time, lblank, species
+ DOUBLE PRECISION neu_max, pec_max, cou_max
+ DOUBLE PRECISION difmaxfold, difmaxtold, difmaxcold
+ DOUBLE PRECISION relaxold, relaxf, relaxt, relaxc, relaxs
+
+ ! Local non linear tolerance variables for convergence check
+ DOUBLE PRECISION loc_nltolf,loc_nltolt,loc_nltolc,loc_nltols
+!
+ LOGICAL converged, lcon_sum
+ EXTERNAL converged, lblank
+
+
+ ! Initialisation
+ ! --------------
+
+ ! standard output
+ IF (linfos(3)>=2) WRITE(*,*) ' ... forward(picard)'
+
+ ! initial values for variables
+ ijk = i0*j0*k0
+ mode = 0
+ iter_nl = 0
+
+ ! initialize nonlinear solver parameters: flow
+ loc_nltolf = nltolf
+#ifdef pres_base
+! convert [MPa] into [Pa]
+ loc_nltolf = nltolf*pa_conv
+#endif
+ difmaxf = 1.0D9*loc_nltolf
+ if (linfos(3)>=2) then
+ WRITE(*,*) 'difmaxf = ', difmaxf
+ end if
+ relaxf = nlrelaxf
+ difrmsf = big
+
+ ! initialize nonlinear solver parameters: temp
+ loc_nltolt = nltolt
+ difmaxt = 1.0D9*loc_nltolt
+ difrmst = big
+ relaxt = nlrelaxt
+
+ ! initialize nonlinear solver parameters: conc
+ loc_nltolc = nltolc
+ difmaxc = 1.0D9*loc_nltolc
+ difrmsc = big
+ relaxc = nlrelaxc
+
+ ! initialize nonlinear solver parameters: satn
+ loc_nltols = nltols
+ difmaxs = 1.0D9*loc_nltols
+ difrmss = big
+ relaxs = nlrelaxs
+
+ ! init history [1] for flow
+ lcon(1,ismpl) = converged(difmaxf,loc_nltolf,-1,conv_hlen, &
+ conv_hmax,conv_history(1,1,ismpl),conv_chlen(1,ismpl), &
+ conv_ipos(1,ismpl))
+ ! init history [2] for temperature
+ lcon(2,ismpl) = converged(difmaxt,loc_nltolt,-2,conv_hlen, &
+ conv_hmax,conv_history(1,1,ismpl),conv_chlen(1,ismpl), &
+ conv_ipos(1,ismpl))
+ ! init history for concentration
+ DO i = 4, ntrans + 3
+ lcon(i,ismpl) = converged(difmaxc,loc_nltolc,-i,conv_hlen, &
+ conv_hmax,conv_history(1,1,ismpl),conv_chlen(1,ismpl), &
+ conv_ipos(1,ismpl))
+ END DO
+
+ ! pre-set to enter the computation at least once
+ lcon_sum = .FALSE.
+
+! -------- begin nonlinear iteration
+! ----------------------------------
+! LOOP = ITERATION lcon_sum - error !!!
+! LOOP = ITERATION difmaxf,difmaxt,difmaxc - wrong !!!
+!$TAF LOOP = ITERATION head,temp,conc,difmaxf,difmaxt,difmaxc
+ DO WHILE ( .NOT. lcon_sum .AND. iter_nl<maxiter_nl)
+! --------
+
+ ! Preprocessing
+ ! -------------
+
+ ! loop Counter for outer nonlinear iteration
+ iter_nl = iter_nl + 1
+
+ ! save old variable arrays for checking difference later
+ CALL old_save(cgen_fw,ismpl)
+
+ ! static relaxation (only flow and temperature)
+ IF (transient .AND. tr_switch(ismpl)) THEN
+ call static_relaxation(ijk,ismpl)
+ END IF
+
+ ! user directory functions
+ CALL calc_user(ismpl)
+
+#ifdef head_base
+ ! update pressure for current head
+ CALL head2pres(1,ismpl)
+#endif
+#ifdef pres_base
+ ! update head from current pressure
+ CALL pres2head(1,ismpl)
+#endif
+
+ ! Flow equation
+ ! -------------
+
+ ! Call solver
+ IF (head_active .OR. pres_active) THEN
+#ifdef head_base
+ ! head computation
+ CALL calc_head(ismpl)
+#endif
+#ifdef pres_base
+ ! pressure computation
+ CALL calc_pres(ismpl)
+#endif
+ ELSE
+ lcon(1,ismpl) = .TRUE.
+ END IF
+
+ ! evaluate flow
+ IF (head_active .OR. pres_active) THEN
+
+ ! Neumann numbers
+ IF (transient .AND. tr_switch(ismpl) .AND. linfos(3)>=1) THEN
+#ifdef head_base
+ CALL neumann_head(neu_max,ismpl)
+#endif
+#ifdef pres_base
+ CALL neumann_pres(neu_max,ismpl)
+#endif
+!? CALL Courant(Cou_max,ismpl)
+ END IF
+
+ ! compute difference
+ difmaxfold = difmaxf
+#ifdef head_base
+ if (linfos(3)>=2) then
+ WRITE(*,*) 'Check change with difmaxf = ', difmaxf
+ end if
+ CALL check_change(mode,pv_head,loc_nltolf,difrmsf,difmaxf,i0,j0,k0, &
+ head(1,1,1,ismpl),headold(1,cgen_fw,ismpl),ismpl)
+#endif
+#ifdef pres_base
+ CALL check_change(mode,pv_pres,loc_nltolf,difrmsf,difmaxf,i0,j0,k0, &
+ pres(1,1,1,ismpl),presold(1,cgen_fw,ismpl),ismpl)
+! Include non-linear residual in error
+ difmaxf= ABS(difmaxf)
+#endif
+
+ ! check for convergence head/pressure
+ lcon(1,ismpl) = converged(difmaxf,loc_nltolf,1,conv_hlen, &
+ conv_hmax,conv_history(1,1,ismpl),conv_chlen(1,ismpl), &
+ conv_ipos(1,ismpl))
+
+ ! adaptive relaxation
+ IF (iter_nl>=2) THEN
+
+ ! relaxation for better convergence
+ IF (nladapt==1) THEN
+ relaxold = relaxf
+ ! DANGER not working for saturation !
+ CALL nl_relax(iter_nl,difmaxf,difmaxfold,nlmaxf,relaxf, &
+ relaxold,ismpl)
+ END IF
+#ifdef head_base
+ ! relaxing head
+ CALL dscal(ijk,relaxf,head(1,1,1,ismpl),1)
+ CALL daxpy(ijk,1.0D0-relaxf,headold(1,cgen_fw,ismpl),1, &
+ head(1,1,1,ismpl),1)
+#endif
+#ifdef pres_base
+ ! relaxing pressure
+ CALL dscal(ijk,relaxf,pres(1,1,1,ismpl),1)
+ CALL daxpy(ijk,1.0D0-relaxf,presold(1,cgen_fw,ismpl),1, &
+ pres(1,1,1,ismpl),1)
+#endif
+ END IF
+
+ END IF
+
+ ! Heat equation
+ ! -------------
+
+ ! Call solver
+ IF (temp_active) THEN
+ CALL calc_temp(ismpl)
+ ELSE
+ lcon(2,ismpl) = .TRUE.
+ END IF
+
+ ! Evaluate temperature
+ IF (temp_active) THEN
+
+ IF (transient .AND. tr_switch(ismpl) .AND. linfos(3)>=1) &
+ THEN
+ CALL courant(cou_max,ismpl)
+ CALL neumann_temp(neu_max,ismpl)
+ CALL peclet_temp(pec_max,ismpl)
+ END IF
+
+ ! compute difference
+ difmaxtold = difmaxt
+ CALL check_change(mode,pv_temp,loc_nltolt,difrmst,difmaxt,i0,j0,k0, &
+ temp(1,1,1,ismpl),tempold(1,cgen_fw,ismpl),ismpl)
+
+ ! check for convergence
+ lcon(2,ismpl) = converged(difmaxt,loc_nltolt,2,conv_hlen, &
+ conv_hmax,conv_history(1,1,ismpl),conv_chlen(1,ismpl), &
+ conv_ipos(1,ismpl))
+
+ ! adaptive relaxation
+ IF (iter_nl>=2) THEN
+ ! relaxation for better convergence
+ IF (nladapt==1) THEN
+ relaxold = relaxt
+ CALL nl_relax(iter_nl,difmaxt,difmaxtold,nlmaxt,relaxt, &
+ relaxold,ismpl)
+ END IF
+ CALL dscal(ijk,relaxt,temp(1,1,1,ismpl),1)
+ CALL daxpy(ijk,1.0D0-relaxt,tempold(1,cgen_fw,ismpl),1, &
+ temp(1,1,1,ismpl),1)
+ END IF
+
+ END IF
+
+ ! Open spot for future implementation of another equation at
+ ! lcon(3,ismpl)
+ lcon(3,ismpl) = .TRUE.
+
+ ! Transport equation
+ ! -------------
+
+ IF (trac_active) THEN
+ IF (linfos(3)>=2) WRITE(*,*) ' ... calc_conc (tracer)'
+ END IF
+ DO species = 1, ntrac
+
+ ! Call solver
+ IF (trac_active) THEN
+ CALL calc_conc(species,ismpl)
+ ELSE
+ lcon(3+species,ismpl) = .TRUE.
+ END IF
+
+ ! evaluate concentration
+ IF (trac_active) THEN
+
+ IF (transient .AND. tr_switch(ismpl) .AND. &
+ linfos(3)>=1 .AND. species==1) THEN
+ CALL courant(cou_max,ismpl)
+ CALL neumann_conc(neu_max,ismpl)
+ CALL peclet_conc(pec_max,ismpl)
+ END IF
+
+ ! compute difference
+ difmaxcold = difmaxc
+
+ ! Check change
+ CALL check_change(mode,pv_conc,loc_nltolc,difrmsc,difmaxc,i0,j0,k0, &
+ conc(1,1,1,species,ismpl),concold(1,species,cgen_fw, &
+ ismpl),ismpl)
+
+ ! check for convergence
+ lcon(3+species,ismpl) = converged(difmaxc,loc_nltolc, &
+ 3+species,conv_hlen,conv_hmax,conv_history(1,1,ismpl), &
+ conv_chlen(1,ismpl),conv_ipos(1,ismpl))
+
+ ! adaptive relaxation
+ IF (iter_nl>=2) THEN
+ ! relaxation for better convergence
+ IF (nladapt==1) THEN
+ relaxold = relaxc
+ CALL nl_relax(iter_nl,difmaxc,difmaxcold,nlmaxc, &
+ relaxc,relaxold,ismpl)
+ END IF
+ CALL dscal(ijk,relaxc,conc(1,1,1,species,ismpl),1)
+ CALL daxpy(ijk,1.0D0-relaxc,concold(1,species,cgen_fw, &
+ ismpl),1,conc(1,1,1,species,ismpl),1)
+ END IF
+
+ conc_conv(species,ismpl) = difmaxc
+
+ END IF
+
+ END DO
+
+ ! Postprocessing
+ ! -------------
+
+! check whether pres/temp/(conc) in domain of props validity
+ CALL check_domain(ismpl)
+
+! summarise all convergency criteria
+ lcon_sum = .TRUE.
+ DO i = 1, conv_hmax
+ IF ( .NOT. lcon(i,ismpl)) lcon_sum = .FALSE.
+ END DO
+
+ ! generate convergency output
+ IF (linfos(3)>=1) THEN
+#ifdef head_base
+ WRITE(*,'(1A,1I6,2(1A,1e16.8))') ' [I] : iter_nl =', iter_nl, &
+ ', difmaxh =', difmaxf, ', difmaxt =', difmaxt
+#endif
+#ifdef pres_base
+ WRITE(*,'(1A,1I6,2(1A,1e16.8))') ' [I] : iter_nl =', iter_nl, &
+ ', difmaxp =', difmaxf*Pa_conv1, ', difmaxt =', difmaxt, &
+ ', difmaxs =', difmaxs
+#endif
+ IF (ntrac>=1) WRITE(*,'(1A,99e16.8)') ' difmaxc[*] =', (conc_conv(i,ismpl),i=1,ntrac)
+ END IF
+ IF ((runmode>=-1) .AND. ( .NOT. write_iter_disable)) THEN
+ IF (linfos(3)>=2) WRITE(*,'(3A)') ' [W] : "', status_log(1:lblank(status_log)), '"'
+ OPEN(76,file=status_log,status='unknown',position='append')
+#ifdef head_base
+ WRITE(76,'(I11,99e16.8)') iter_nl, difmaxf, difmaxt,(conc_conv(i,ismpl),i=1,ntrac)
+#endif
+#ifdef pres_base
+ WRITE(76,'(I11,99e16.8)') iter_nl, difmaxf*Pa_conv1, difmaxt, difmaxs, (conc_conv(i,ismpl),i=1,ntrac)
+#endif
+ CLOSE(76)
+ END IF
+
+ ! calculate total salinity (used only in property module
+ ! basc)
+ CALL set_tsal(ismpl)
+
+#ifdef DEBUG
+ DO i = 1, n_debugout
+ IF (debugout(1,i)==iter_time .AND. debugout(2,i)==iter_nl) THEN
+ WRITE(project_sfx(ismpl),'(1A1,1I5.5,1A1,1I3.3)') '_', iter_time, 'x', iter_nl
+ CALL write_tecdiff(-2,ismpl)
+ project_sfx(ismpl) = ' '
+ END IF
+ END DO
+#endif
+
+! --------
+ END DO
+! -------- end nonlinear iteration
+! --------------------------------
+
+ ! Variable time step
+ call set_var_deltat(iter_nl, ismpl)
+
+ ! Standard output
+ IF (transient .AND. tr_switch(ismpl)) THEN
+ IF (linfos(3)>=2) WRITE(*,'(1A,1I10,1A)') 'timestep ', iter_time, ', leaving nonlinear iteration'
+ END IF
+
+ RETURN
+
+ END SUBROUTINE forward_picard
diff --git a/forward/forward_preparation.f90 b/forward/forward_preparation.f90
new file mode 100644
index 0000000..5c4a291
--- /dev/null
+++ b/forward/forward_preparation.f90
@@ -0,0 +1,70 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief wrapper for preparation of forward run, mostly input
+!> @param[in] filename input filename as read from shemade.job
+!> @param[inout] ismpl local sample index
+!> @details
+!> This input wrapper calls the read-in routines and initializes
+!> first output to the status log and the command line.
+subroutine forward_preparation(filename, ismpl)
+
+ use mod_genrl, only: runmode
+ use mod_genrlc, only: filename_data
+#ifndef noHDF
+ use mod_input_file_parser_hdf5, only: h5parse_open_datafile, &
+ h5parse_close_datafile
+#endif
+
+ implicit none
+
+ integer :: ismpl
+
+ character (len=80), intent (in) :: filename
+
+ integer, external :: lblank
+ logical, external :: test_option
+
+#ifndef noHDF
+ CALL h5parse_open_datafile(filename)
+#endif
+
+ ! read forward model
+ CALL read_model(filename,ismpl)
+ CALL read_control(filename,ismpl)
+ ! only forward propcessing =<1
+ runmode = min(runmode,1)
+ ! read timestep parameter
+ CALL read_time(filename,ismpl)
+ ! read data
+ IF (runmode>0) CALL read_data(filename_data,ismpl)
+ ! split units
+ CALL read_split(filename,ismpl)
+
+ ! First status log output
+ call write_status_log(filename, ismpl)
+
+#ifndef noHDF
+ CALL h5parse_close_datafile()
+#endif
+
+end subroutine forward_preparation
diff --git a/forward/forward_wrapper.f90 b/forward/forward_wrapper.f90
new file mode 100644
index 0000000..ae084df
--- /dev/null
+++ b/forward/forward_wrapper.f90
@@ -0,0 +1,43 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief wrapper for the forward simulation call
+!> @param[in] iter time iteration counter
+!> @param[in] ismpl local sample index
+!> @details
+!> Seperates the equation system solving from the specific nonlinear
+!> solver (Picard based)\n
+ subroutine forward_wrapper(iter,ismpl)
+
+ implicit none
+
+ integer :: ismpl
+
+ integer, intent (in) :: iter
+
+! ######### Forward Iteration ######
+ call forward_picard(iter,ismpl)
+! ##################################
+
+ return
+
+ end subroutine forward_wrapper
diff --git a/forward/forward_write.f90 b/forward/forward_write.f90
new file mode 100644
index 0000000..f0967ab
--- /dev/null
+++ b/forward/forward_write.f90
@@ -0,0 +1,38 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief wrapper routine for common write output
+!> @param[in] i index/iteration number
+!> @param[in] ismpl local sample index
+ SUBROUTINE forward_write(i,ismpl)
+ IMPLICIT NONE
+ INTEGER i, ismpl
+!
+ CALL write_hdf(i,ismpl)
+ CALL write_tecplot(i,ismpl)
+ CALL write_tecplotc(i,ismpl)
+ CALL write_vtk(i,ismpl)
+ CALL write_text(i,ismpl)
+ CALL write_user(i,ismpl)
+ CALL write_logs(i,ismpl)
+ RETURN
+ END
diff --git a/forward/get_tpbcalbe.f90 b/forward/get_tpbcalbe.f90
new file mode 100644
index 0000000..6c91bb3
--- /dev/null
+++ b/forward/get_tpbcalbe.f90
@@ -0,0 +1,73 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief time depended boundary condition modificators
+!> @param[out] malfa alfa modificator
+!> @param[out] mbeta beta modificator
+!> @param[in] tpbcu time period BC table index
+!> @param[in] ismpl local sample index
+!> @details
+!> "GET Time Periods Boundary Condition ALfa & BEta"\n
+!> get the alfa and beta modificators for time dependend bc-values\n
+ SUBROUTINE get_tpbcalbe(malfa,mbeta,tpbcu,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_time
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: k
+
+ INTEGER tpbcu, imt
+ DOUBLE PRECISION malfa, mbeta, mtime
+ INTRINSIC abs
+
+! default - when not time depended
+ malfa = 0.0D0
+ mbeta = 1.0D0
+!
+ IF (tpbcu>0) THEN
+ k = 0
+ imt = 0
+! next bc-tp entry
+100 imt = imt + 1
+ mtime = bcperiod(imt,1,tpbcu,ismpl)
+ IF (mtime<=simtime(ismpl)) THEN
+ malfa = bcperiod(imt,2,tpbcu,ismpl)
+ mbeta = bcperiod(imt,3,tpbcu,ismpl)
+! save index of the valid start time
+ k = imt
+ END IF
+!
+! !!! this IF statement (with the GOTO) needs to be outside of the
+! other "mtime<=simtime(ismpl)" scopes, to generate reverse-mode code !!!
+ IF (mtime<=simtime(ismpl).AND.imt<ibcperiod(tpbcu)) GO TO 100
+ IF (k>0) THEN
+ IF ( .NOT. lbcperiod(k,tpbcu)) THEN
+! disable this BC (switched off)
+ tpbcu = -abs(tpbcu)
+ END IF
+ END IF
+ END IF
+!
+ RETURN
+ END
diff --git a/forward/head/calc_head.f90 b/forward/head/calc_head.f90
new file mode 100644
index 0000000..fdd5ba6
--- /dev/null
+++ b/forward/head/calc_head.f90
@@ -0,0 +1,95 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief top level routine for setup aand computing head flow
+!> @param[in] ismpl local sample index
+ SUBROUTINE calc_head(ismpl)
+ use arrays
+ use mod_genrlc
+ use mod_genrl
+ use mod_flow
+ use mod_time
+ use mod_linfos
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i
+ INCLUDE 'OMP_TOOLS.inc'
+ INTEGER ijk
+
+
+ IF (linfos(3)>=2) WRITE(*,*) ' ... calc_head'
+!
+#ifdef fOMP
+!$OMP parallel num_threads(Tlevel_1)
+!$ call omp_binding(ismpl)
+#endif
+
+ ijk = i0*j0*k0
+
+ ! default to mark a non-boundary
+!$OMP master
+ DO i = 1, ijk
+ bc_mask(i,ismpl) = '+'
+ END DO
+!$OMP end master
+
+ ! initialize coefficients for sparse solvers as zero
+ CALL omp_set_dval(ijk,0.D0,a(1,1,1,ismpl))
+ CALL omp_set_dval(ijk,0.D0,b(1,1,1,ismpl))
+ CALL omp_set_dval(ijk,0.D0,c(1,1,1,ismpl))
+ CALL omp_set_dval(ijk,0.D0,d(1,1,1,ismpl))
+ CALL omp_set_dval(ijk,0.D0,e(1,1,1,ismpl))
+ CALL omp_set_dval(ijk,0.D0,f(1,1,1,ismpl))
+ CALL omp_set_dval(ijk,0.D0,g(1,1,1,ismpl))
+ CALL omp_set_dval(ijk,0.D0,w(1,1,1,ismpl))
+
+!$OMP barrier
+
+ ! calculate coefficients
+ CALL set_hcoef(ismpl)
+
+ ! set fluid sources/sinks (currently hardcoded to zero)
+ CALL set_hq(ismpl)
+
+!$OMP barrier
+
+ ! calculate coefficients for right hand side
+ CALL set_hcoefrs(ismpl)
+
+#ifdef fOMP
+!$OMP end parallel
+#endif
+
+ ! set boundary conditions
+ CALL set_hbc(ismpl)
+
+ ! standard output
+ IF (linfos(3)>=2) WRITE(*,*) ' ... solve(head)'
+
+ ! solve head
+ CALL solve(pv_head,-1,head(1,1,1,ismpl),errf,aparf,controlf, &
+ ismpl)
+
+ RETURN
+
+ END
diff --git a/forward/head/hbuoy.f90 b/forward/head/hbuoy.f90
new file mode 100644
index 0000000..5414941
--- /dev/null
+++ b/forward/head/hbuoy.f90
@@ -0,0 +1,58 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculate buoyancy for head equation
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return buoyancy
+!> @details
+!>calculate buoyancy for head equation\n
+!>sign convention: negative for positive buoyancy\n
+ DOUBLE PRECISION FUNCTION buoy(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_flow
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION rhor, rhav, hh, h0, h1, prod, summ
+ DOUBLE PRECISION rhof, kz, visf
+ EXTERNAL rhof, kz, visf
+
+ rhav = 0.5D0*(rhof(i,j,k+1,ismpl)+rhof(i,j,k,ismpl))
+ rhor = (rhav-rref)/rref
+
+ hh = 0.D0
+ h0 = kz(i,j,k,ismpl)*rhof(i,j,k,ismpl)*grav/visf(i,j,k,ismpl)
+ h1 = kz(i,j,k+1,ismpl)*rhof(i,j,k+1,ismpl)*grav/ &
+ visf(i,j,k+1,ismpl)
+ summ = h0 + h1
+ prod = h0*h1
+ IF (summ>0.D0) hh = 2.0D0*prod/summ
+
+ buoy = hh*rhor
+
+ RETURN
+ END
diff --git a/forward/head/head2pres.f90 b/forward/head/head2pres.f90
new file mode 100644
index 0000000..b8c1bff
--- /dev/null
+++ b/forward/head/head2pres.f90
@@ -0,0 +1,51 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief compute pressure from head
+!> @param[in] init flag: 0-init, 1-normal setup
+!> @param[in] ismpl local sample index
+!> @details
+!> parallelisation wrapper for pressure computation
+ SUBROUTINE head2pres(init,ismpl)
+ use mod_linfos
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ integer :: ismpl
+ INCLUDE 'OMP_TOOLS.inc'
+ INTEGER init
+
+ IF (linfos(3)>=2) WRITE(*,'(A,I1,A)') &
+ ' ... pressure (init=', init, ')'
+!
+#ifdef fOMP
+!$OMP parallel num_threads(Tlevel_1)
+!$ call omp_binding(ismpl)
+#endif
+!
+ CALL omp_head2pres(init,ismpl)
+!
+#ifdef fOMP
+!$OMP end parallel
+#endif
+!
+ RETURN
+ END
diff --git a/forward/head/hfluxes.f90 b/forward/head/hfluxes.f90
new file mode 100644
index 0000000..d784db6
--- /dev/null
+++ b/forward/head/hfluxes.f90
@@ -0,0 +1,328 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculate velocities at cell faces
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return x velocity (m/s)
+ DOUBLE PRECISION FUNCTION vx(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION dif, ti
+ EXTERNAL ti
+
+ vx = 0.D0
+ if (.not. head_active .and. vdefaultswitch) then
+ vx = vdefault(1,ismpl)
+ end if
+ IF (i0>1 .AND. i<i0 .AND. head_active) THEN
+#ifdef head_base
+ dif = head(i+1,j,k,ismpl) - head(i,j,k,ismpl)
+ vx = -ti(i,j,k,ismpl)*dif
+#endif
+ END IF
+ RETURN
+ END
+
+!> @brief calculate velocities at cell faces
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return y velocity (m/s)
+ DOUBLE PRECISION FUNCTION vy(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION dif, tj
+ EXTERNAL tj
+
+ vy = 0.D0
+ if (.not. head_active .and. vdefaultswitch) then
+ vy = vdefault(2,ismpl)
+ end if
+ IF (j0>1 .AND. j<j0 .AND. head_active) THEN
+#ifdef head_base
+ dif = head(i,j+1,k,ismpl) - head(i,j,k,ismpl)
+ vy = -tj(i,j,k,ismpl)*dif
+#endif
+ END IF
+ RETURN
+ END
+
+!> @brief calculate velocities at cell faces
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return z velocity (m/s)
+ DOUBLE PRECISION FUNCTION vz(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION dif, tk, buoy
+ EXTERNAL tk, buoy
+
+ vz = 0.D0
+ if (.not. head_active .and. vdefaultswitch) then
+ vz = vdefault(3,ismpl)
+ end if
+ IF (k0>1 .AND. k<k0 .AND. head_active) THEN
+#ifdef head_base
+ dif = head(i,j,k+1,ismpl) - head(i,j,k,ismpl)
+ vz = -tk(i,j,k,ismpl)*dif - buoy(i,j,k,ismpl)
+#endif
+ END IF
+ RETURN
+ END
+
+!> @brief calculate velocities at cell centers
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return x velocity (m/s)
+ DOUBLE PRECISION FUNCTION vxc(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+ DOUBLE PRECISION vx, amean
+ EXTERNAL vx, amean
+
+ vxc = 0.D0
+ IF (i0<=1 .OR. .NOT.head_active) RETURN
+#ifdef head_base
+ IF (i>1 .AND. i<i0) THEN
+ vxc = amean(vx(i,j,k,ismpl),vx(i-1,j,k,ismpl))
+ ELSE IF (i==1) THEN
+ vxc = vx(i,j,k,ismpl)
+ ELSE IF (i==i0) THEN
+ vxc = vx(i-1,j,k,ismpl)
+ END IF
+#endif
+ RETURN
+ END
+
+!> @brief calculate y-velocities at cell center
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return y velocity (m/s)
+ DOUBLE PRECISION FUNCTION vyc(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_flow
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION vy, amean
+ EXTERNAL vy, amean
+
+ vyc = 0.D0
+ IF (j0<=1 .OR. .NOT.head_active) RETURN
+#ifdef head_base
+ IF (j>1 .AND. j<j0) THEN
+ vyc = amean(vy(i,j,k,ismpl),vy(i,j-1,k,ismpl))
+ ELSE IF (j==1) THEN
+ vyc = vy(i,j,k,ismpl)
+ ELSE IF (j==j0) THEN
+ vyc = vy(i,j-1,k,ismpl)
+ END IF
+#endif
+ RETURN
+ END
+
+!> @brief calculate z-velocities at cell center
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return z velocity (m/s)
+ DOUBLE PRECISION FUNCTION vzc(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_flow
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION vz, amean
+ EXTERNAL vz, amean
+
+ vzc = 0.D0
+ IF (k0<=1 .OR. .NOT.head_active) RETURN
+#ifdef head_base
+ IF (k>1 .AND. k<k0) THEN
+ vzc = amean(vz(i,j,k,ismpl),vz(i,j,k-1,ismpl))
+ ELSE IF (k==1) THEN
+ vzc = vz(i,j,k,ismpl)
+ ELSE IF (k==k0) THEN
+ vzc = vz(i,j,k-1,ismpl)
+ END IF
+#endif
+ RETURN
+ END
+
+!> @brief harmonic mean Kx on cell faces in x direction over delx*
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return x hydraulic conductivity over delx* (1/s)
+!> @details
+!> Compute the harmonic mean of Kx on the cell face in positive
+!> x-direction from the current node (i, j, k) divided by the
+!> x-distance of the current node (i, j, k) to the neighboring node
+!> (i+1, j, k).
+!>
+!> delx* = 0.5 ( delx(i) + delx(i+1) )
+!>
+!> Kx / delx* = [ 0.5*delx(i+1)/K(i+1) + 0.5*delx(i)/K(i) ]**-1
+!>
+!> = [ ( 0.5* K(i)* delx(i+1) + 0.5*K(i+1)* delx(i) ) / ( K(i)*K(i+1) ) ]**-1
+!>
+!> = [ ( 0.5 * summ ) / (prod) ]**-1 = 2.0*prod/summ
+ DOUBLE PRECISION FUNCTION ti(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_flow
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION f1, f2, prod, summ, kx, rhof, visf
+ EXTERNAL kx, rhof, visf
+
+ ti = 0.D0
+ IF (i0>1 .AND. i<i0) THEN
+ f1 = kx(i,j,k,ismpl)*rhof(i,j,k,ismpl)*grav/ &
+ visf(i,j,k,ismpl)
+ f2 = kx(i+1,j,k,ismpl)*rhof(i+1,j,k,ismpl)*grav/ &
+ visf(i+1,j,k,ismpl)
+ prod = f1*f2
+ summ = f1*delx(i+1) + f2*delx(i)
+ IF (summ>0.D0) ti = 2.D0*prod/summ
+ END IF
+ RETURN
+ END
+
+!> @brief harmonic mean Ky on cell faces in y direction over dely*
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return y hydraulic conductivity over dely* (1/s)
+!> @details
+!> Compute the harmonic mean of Ky on the cell face in positive
+!> y-direction from the current node (i, j, k) divided by the
+!> y-distance of the current node (i, j, k) to the neighboring node
+!> (i, j+1, k).
+!>
+!> dely* = 0.5 ( dely(j) + dely(j+1) )
+!>
+!> Ky / dely* = [ 0.5*dely(j+1)/K(j+1) + 0.5*dely(j)/K(j) ]**-1
+!>
+!> = [ ( 0.5* K(j)* dely(j+1) + 0.5*K(j+1)* dely(j) ) / ( K(j)*K(j+1) ) ]**-1
+!>
+!> = [ ( 0.5 * summ ) / (prod) ]**-1 = 2.0*prod/summ
+ DOUBLE PRECISION FUNCTION tj(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_flow
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION f1, f2, prod, summ, ky, rhof, visf
+ EXTERNAL ky, rhof, visf
+
+ tj = 0.D0
+ IF (j0>1 .AND. j<j0) THEN
+ f1 = ky(i,j,k,ismpl)*rhof(i,j,k,ismpl)*grav/ &
+ visf(i,j,k,ismpl)
+ f2 = ky(i,j+1,k,ismpl)*rhof(i,j+1,k,ismpl)*grav/ &
+ visf(i,j+1,k,ismpl)
+ prod = f1*f2
+ summ = f1*dely(j+1) + f2*dely(j)
+ IF (summ>0.D0) tj = 2.D0*prod/summ
+ END IF
+ RETURN
+ END
+
+!> @brief harmonic mean Kz on cell faces in z direction over delz*
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return z hydraulic conductivity over delz* (1/s)
+!> @details
+!> Compute the harmonic mean of Kz on the cell face in positive
+!> z-direction from the current node (i, j, k) divided by the
+!> z-distance of the current node (i, j, k) to the neighboring node
+!> (i, j, k+1).
+!>
+!> delz* = 0.5 ( delz(k) + delz(k+1) )
+!>
+!> Kz / delz* = [ 0.5*delz(k+1)/K(k+1) + 0.5*delz(k)/K(k) ]**-1
+!>
+!> = [ ( 0.5* K(k)* delz(k+1) + 0.5*K(k+1)* delz(k) ) / ( K(k)*K(k+1) ) ]**-1
+!>
+!> = [ ( 0.5 * summ ) / (prod) ]**-1 = 2.0*prod/summ
+ DOUBLE PRECISION FUNCTION tk(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_flow
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION f1, f2, prod, summ, kz, rhof, visf
+ EXTERNAL kz, rhof, visf
+
+ tk = 0.D0
+ IF (k0>1 .AND. k<k0) THEN
+ f1 = kz(i,j,k,ismpl)*rhof(i,j,k,ismpl)*grav/ &
+ visf(i,j,k,ismpl)
+ f2 = kz(i,j,k+1,ismpl)*rhof(i,j,k+1,ismpl)*grav/ &
+ visf(i,j,k+1,ismpl)
+ prod = f1*f2
+ summ = f1*delz(k+1) + f2*delz(k)
+ IF (summ>0.D0) tk = 2.D0*prod/summ
+ END IF
+ RETURN
+ END
diff --git a/forward/head/hstor.f90 b/forward/head/hstor.f90
new file mode 100644
index 0000000..ee498a5
--- /dev/null
+++ b/forward/head/hstor.f90
@@ -0,0 +1,44 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates the bulk storativity
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return bulk storativity
+!> @details
+!> storb(i,j,k,ismpl) calculates the bulk storativity \n
+!> at node(i,j,k).\n
+ DOUBLE PRECISION FUNCTION hstor(i,j,k,ismpl)
+ use arrays
+ use mod_flow
+ IMPLICIT NONE
+
+ INTEGER i, j, k, ismpl
+ DOUBLE PRECISION rhof, compm, compf, por
+ EXTERNAL rhof, compm, compf, por
+
+ hstor = grav*rhof(i,j,k,ismpl)*(compm(i,j,k,ismpl)+por(i,j,k, &
+ ismpl)*compf(i,j,k,ismpl))
+ RETURN
+ END
diff --git a/forward/head/neumann_head.f90 b/forward/head/neumann_head.f90
new file mode 100644
index 0000000..e651cbe
--- /dev/null
+++ b/forward/head/neumann_head.f90
@@ -0,0 +1,214 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief OpenMP wrapper for "omp_neumann_head"
+!> @param[out] neumann_max neumann criteria
+!> @param[in] ismpl local sample index
+ SUBROUTINE neumann_head(neumann_max,ismpl)
+ use mod_genrl
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ integer :: ismpl
+ INCLUDE 'OMP_TOOLS.inc'
+ DOUBLE PRECISION neumann_max
+
+#ifdef fOMP
+!$OMP parallel num_threads(Tlevel_1)
+!$ call omp_binding(ismpl)
+#endif
+ CALL omp_neumann_head(neumann_max,ismpl)
+#ifdef fOMP
+!$OMP end parallel
+#endif
+
+ RETURN
+ END
+
+!> @brief calculate grid neuman numbers (head)
+!> @param[out] neumann_max maximal neuman number
+!> @param[in] ismpl local sample index
+ SUBROUTINE omp_neumann_head(neumann_max,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_flow
+ use mod_time
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+
+ INTEGER c1, c2, c3
+ DOUBLE PRECISION neumann_maxx
+ DOUBLE PRECISION neumann_minx
+ DOUBLE PRECISION neumann_avgx
+ DOUBLE PRECISION neumann_maxy
+ DOUBLE PRECISION neumann_miny
+ DOUBLE PRECISION neumann_avgy
+ DOUBLE PRECISION neumann_maxz
+ DOUBLE PRECISION neumann_minz
+ DOUBLE PRECISION neumann_avgz
+ ! DOUBLE PRECISION neumann_x
+ ! DOUBLE PRECISION neumann_y
+ ! DOUBLE PRECISION neumann_z
+ DOUBLE PRECISION val
+ DOUBLE PRECISION neumann_max
+ DOUBLE PRECISION delt
+ DOUBLE PRECISION fac
+ DOUBLE PRECISION davg
+ DOUBLE PRECISION deltat
+ EXTERNAL deltat
+ DOUBLE PRECISION ti, tj, tk, rhof, visf, por, compf, compm, &
+ hstor
+ EXTERNAL ti, tj, tk, rhof, visf, por, compf, compm, hstor
+
+
+ delt = deltat(simtime(ismpl),ismpl)
+
+ IF ( .NOT. (transient .AND. tr_switch(ismpl))) THEN
+!$OMP master
+ WRITE(*,*) ' neumann-head: not defined for steady state'
+!$OMP end master
+ RETURN
+ ELSE IF (linfos(3)>=2) THEN
+!$OMP master
+ WRITE(*,*)
+ WRITE(*,'(A,1e16.8)') ' ... neumann-head: delt/tunit = ', &
+ delt/tunit
+ WRITE(*,*)
+!$OMP end master
+ END IF
+
+! val in x
+ c1 = 0
+ neumann_maxx = small
+ neumann_minx = big
+ neumann_avgx = 0.0D0
+!$OMP do schedule(static)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 2, i0 - 1
+ c1 = c1 + 1
+ davg = 0.5D0*(delx(i)+delx(i+1))
+ fac = delt/hstor(i,j,k,ismpl)
+ val = fac*ti(i,j,k,ismpl)/(davg*davg)
+ IF (val>neumann_maxx) neumann_maxx = val
+ IF (val<neumann_minx) neumann_minx = val
+ neumann_avgx = neumann_avgx + val
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+
+! val in y
+ c2 = 0
+ neumann_maxy = small
+ neumann_miny = big
+ neumann_avgy = 0.0D0
+!$OMP do schedule(static)
+ DO k = 1, k0
+ DO j = 2, j0 - 1
+ DO i = 1, i0
+ c2 = c2 + 1
+ davg = 0.5D0*(dely(j)+dely(j+1))
+ fac = delt/hstor(i,j,k,ismpl)
+ val = fac*tj(i,j,k,ismpl)/(davg*davg)
+ IF (val>neumann_maxy) neumann_maxy = val
+ IF (val<neumann_miny) neumann_miny = val
+ neumann_avgy = neumann_avgy + val
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+
+! val in z
+ c3 = 0
+ neumann_maxz = small
+ neumann_minz = big
+ neumann_avgz = 0.0D0
+!$OMP do schedule(static)
+ DO k = 2, k0 - 1
+ DO j = 1, j0
+ DO i = 1, i0
+ c3 = c3 + 1
+ davg = 0.5D0*(delz(k)+delz(k+1))
+ fac = delt/hstor(i,j,k,ismpl)
+ val = fac*tk(i,j,k,ismpl)/(davg*davg)
+ IF (val>neumann_maxz) neumann_maxz = val
+ IF (val<neumann_minz) neumann_minz = val
+ neumann_avgz = neumann_avgz + val
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+
+! compute global sum for all values
+ CALL omp_summe(neumann_maxx,neumann_minx,neumann_avgx, &
+ neumann_maxy,neumann_miny,neumann_avgy,neumann_maxz, &
+ neumann_minz,neumann_avgz,c1,c2,c3,ismpl)
+
+!$OMP master
+ IF (i0>2) THEN
+ neumann_avgx = neumann_avgx/dble(c1)
+ ELSE
+ neumann_maxx = 0.0D0
+ neumann_minx = 0.0D0
+ neumann_avgx = 0.0D0
+ END IF
+ IF (j0>2) THEN
+ neumann_avgy = neumann_avgy/dble(c2)
+ ELSE
+ neumann_maxy = 0.0D0
+ neumann_miny = 0.0D0
+ neumann_avgy = 0.0D0
+ END IF
+ IF (k0>2) THEN
+ neumann_avgz = neumann_avgz/dble(c3)
+ ELSE
+ neumann_maxz = 0.0D0
+ neumann_minz = 0.0D0
+ neumann_avgz = 0.0D0
+ END IF
+
+ neumann_max = max(neumann_maxx,neumann_maxy,neumann_maxz)
+
+ IF (linfos(3)>=2) THEN
+ WRITE(*,*) 'neumann number for head in x,y,z:'
+ WRITE(*,'(a,1e10.3,a,1e10.3,a,1e10.3)') ' max. : ', &
+ neumann_maxx, ', ', neumann_maxy, ', ', neumann_maxz
+ WRITE(*,'(a,1e10.3,a,1e10.3,a,1e10.3)') ' min. : ', &
+ neumann_minx, ', ', neumann_miny, ', ', neumann_minz
+ WRITE(*,'(a,1e10.3,a,1e10.3,a,1e10.3)') ' avg. : ', &
+ neumann_avgx, ', ', neumann_avgy, ', ', neumann_avgz
+ END IF
+
+ IF (linfos(3)>=1 .AND. neumann_max>0.5D0) THEN
+ WRITE(*,'(a)') '!!!: neumann head greater than 1/2 :'
+ WRITE(*,'(a,1e12.3,a,1e10.3,a,1e10.3)') 'x: ', &
+ neumann_maxx, 'y: ', neumann_maxy, 'z: ', neumann_maxz
+ WRITE(*,*)
+ END IF
+!$OMP end master
+
+ RETURN
+ END
diff --git a/forward/head/omp_head2pres.f90 b/forward/head/omp_head2pres.f90
new file mode 100644
index 0000000..8bd3428
--- /dev/null
+++ b/forward/head/omp_head2pres.f90
@@ -0,0 +1,83 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief pressure in Pa from hydraulic potential und heigth above hz=0.0d0
+!> @param[in] init flag: 0-init, 1-normal setup
+!> @param[in] ismpl local sample index
+!> @details
+!> pressure in MPa from hydraulic potential und height above hz=0.0 \n
+!> p(surface) = 0.1 MPa \n
+!> OUTPUT in Pa\n
+ SUBROUTINE omp_head2pres(init,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_flow
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+ INTEGER init
+ DOUBLE PRECISION psurf
+ DOUBLE PRECISION dif
+ DOUBLE PRECISION zero
+ PARAMETER (zero=0.0D0)
+
+
+! presetting for dirichlet boundary conditions to avoid site effects
+ CALL set_dhbc(ismpl)
+ CALL set_dtbc(ismpl)
+!$OMP barrier
+!
+ psurf = 1.0D5
+!
+ IF (init==0) THEN
+! initialize
+!$OMP do schedule(static) collapse(3)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ dif = head(i,j,k,ismpl) - delza(k)
+ pres(i,j,k,ismpl) = psurf
+ IF (dif>zero) pres(i,j,k,ismpl) = psurf + dif*rref*grav
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+ ELSE
+! pres and temp have already appropriate values
+!$OMP do schedule(static) collapse(3)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ dif = head(i,j,k,ismpl) - delza(k)
+ pres(i,j,k,ismpl) = psurf
+! jbr: pres = (h-z)*rref*grav
+ IF (dif>zero) pres(i,j,k,ismpl) = psurf + &
+ rref*dif*grav
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+ END IF
+!
+ RETURN
+ END
diff --git a/forward/head/set_hbc.f90 b/forward/head/set_hbc.f90
new file mode 100644
index 0000000..c57a34a
--- /dev/null
+++ b/forward/head/set_hbc.f90
@@ -0,0 +1,193 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief modify coefficents for the head equation according to the boundary conditions
+!> @param[in] ismpl local sample index
+!> @details
+!> modify coefficents for the head equation according to the boundary conditions,\n
+!> coefficients are stored as vectors in the diagonals a-g (d center) and rhs in w.\n
+ SUBROUTINE set_hbc(ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_temp
+ use mod_flow
+ use mod_time
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+ integer :: ib
+ INTEGER bcu, tpbcu, bctype, i_dir
+ DOUBLE PRECISION val, malfa, mbeta
+ INTRINSIC max
+
+
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! dirichlet nodes - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ DO ib = first_flow, last_flow
+ i = ibc_data(ib,cbc_i)
+ j = ibc_data(ib,cbc_j)
+ k = ibc_data(ib,cbc_k)
+ bcu = ibc_data(ib,cbc_bcu)
+ tpbcu = max(ibc_data(ib,cbc_bctp),0)
+ bctype = ibc_data(ib,cbc_bt)
+!aw i_dir = ibc_data(ib,cbc_dir)
+! "dirichlet"?, skip otherwise
+ IF (bctype==bt_diri) THEN
+! discrete values
+ IF (bcu<=0) THEN
+ val = dbc_data(ib,1,ismpl)
+ ELSE
+ val = propunit(bcu,idx_hbc,ismpl)
+ END IF
+
+ IF ((tpbcu>0) .AND. nbctp>0) THEN
+! time-dependent bc: val=ac*val+bc
+! get Alfa and Beta modificators
+ CALL get_tpbcalbe(malfa,mbeta,tpbcu,ismpl)
+! update time dependend modification of the bc-value
+ val = malfa + mbeta*val
+ END IF
+
+ IF (tpbcu>=0) THEN
+#ifdef BCMY
+! D = D+my
+ d(i,j,k,ismpl) = d(i,j,k,ismpl) - dbc_data(ib,2,ismpl)
+ w(i,j,k,ismpl) = w(i,j,k,ismpl) - &
+ dbc_data(ib,2,ismpl)*val
+#else
+! standard boundary condition handling
+ a(i,j,k,ismpl) = 0.0D0
+ b(i,j,k,ismpl) = 0.0D0
+ c(i,j,k,ismpl) = 0.0D0
+ e(i,j,k,ismpl) = 0.0D0
+ f(i,j,k,ismpl) = 0.0D0
+ g(i,j,k,ismpl) = 0.0D0
+ d(i,j,k,ismpl) = 1.0D0
+ w(i,j,k,ismpl) = val
+ head(i,j,k,ismpl) = val
+! mark as boundary for normalising the lin. system
+ bc_mask(i+(j-1)*i0+(k-1)*i0*j0,ismpl) = '0'
+#endif
+ END IF
+ END IF
+ END DO
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! neumann nodes - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ DO ib = first_flow, last_flow
+ i = ibc_data(ib,cbc_i)
+ j = ibc_data(ib,cbc_j)
+ k = ibc_data(ib,cbc_k)
+ bcu = ibc_data(ib,cbc_bcu)
+ tpbcu = max(ibc_data(ib,cbc_bctp),0)
+ bctype = ibc_data(ib,cbc_bt)
+ i_dir = ibc_data(ib,cbc_dir)
+! "neumann"?, skip otherwise
+ IF (bctype==bt_neum.OR.bctype==bt_neuw) THEN
+! discrete values
+ IF (bcu<=0) THEN
+ val = dbc_data(ib,1,ismpl)
+ ELSE
+ val = propunit(bcu,idx_hbc,ismpl)
+ END IF
+
+ IF ((tpbcu>0) .AND. nbctp>0) THEN
+! time-dependent bc: val=ac*val+bc
+! get Alfa and Beta modificators
+ CALL get_tpbcalbe(malfa,mbeta,tpbcu,ismpl)
+! update time dependend modification of the bc-value
+ val = malfa + mbeta*val
+ END IF
+
+ IF (tpbcu>=0) THEN
+ IF ((i_dir==0)) val = val/(delx(i)*dely(j)*delz(k))
+ IF ((i_dir==1) .OR. (i_dir==2)) val = val/delx(i)
+ IF ((i_dir==3) .OR. (i_dir==4)) val = val/dely(j)
+ IF ((i_dir==5) .OR. (i_dir==6)) val = val/delz(k)
+ w(i,j,k,ismpl) = w(i,j,k,ismpl) - val
+ END IF
+ END IF
+ END DO
+
+ RETURN
+ END
+
+!> @brief modify HEAD for the head equation according to the boundary conditions
+!> @param[in] ismpl local sample index
+!> @details
+!> modify HEAD for the head equation according to the boundary conditions\n
+ SUBROUTINE set_dhbc(ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_temp
+ use mod_flow
+ use mod_time
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+ integer :: ib
+ INTEGER bcu, tpbcu, bctype
+ DOUBLE PRECISION val, malfa, mbeta
+ INTRINSIC max
+
+
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! dirichlet nodes - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+!$OMP do schedule(static)
+ DO ib = first_flow, last_flow
+ i = ibc_data(ib,cbc_i)
+ j = ibc_data(ib,cbc_j)
+ k = ibc_data(ib,cbc_k)
+ bcu = ibc_data(ib,cbc_bcu)
+ tpbcu = max(ibc_data(ib,cbc_bctp),0)
+ bctype = ibc_data(ib,cbc_bt)
+! "dirichlet"?, skip otherwise
+ IF (bctype==bt_diri) THEN
+! discrete values
+ IF (bcu<=0) THEN
+ val = dbc_data(ib,1,ismpl)
+ ELSE
+ val = propunit(bcu,idx_hbc,ismpl)
+ END IF
+
+ IF ((tpbcu>0) .AND. nbctp>0) THEN
+! time-dependent bc: val=ac*val+bc
+! get Alfa and Beta modificators
+ CALL get_tpbcalbe(malfa,mbeta,tpbcu,ismpl)
+! update time dependend modification of the bc-value
+ val = malfa + mbeta*val
+ END IF
+
+ IF (tpbcu>=0) head(i,j,k,ismpl) = val
+ END IF
+ END DO
+!$OMP end do nowait
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ RETURN
+ END
diff --git a/forward/head/set_hcoef.f90 b/forward/head/set_hcoef.f90
new file mode 100644
index 0000000..11f1625
--- /dev/null
+++ b/forward/head/set_hcoef.f90
@@ -0,0 +1,168 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculate coefficents for the head equation
+!> @param[in] ismpl local sample index
+!> @details
+!> calculate coefficents for the head equation\n
+!> coefficients are stored as vectors in the diagonals a-g (d center) and rhs in w.\n
+ SUBROUTINE set_hcoef(ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_flow
+ use mod_time
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+
+
+ DOUBLE PRECISION ti, tj, tk
+ EXTERNAL ti, tj, tk
+
+
+!$OMP master
+ IF (linfos(3)>=2) WRITE(*,*) ' ... fcoef'
+!$OMP end master
+
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+!$OMP do schedule(static) collapse(3)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+
+ IF (i0>1) THEN
+ IF (i<i0) THEN
+ e(i,j,k,ismpl) = ti(i,j,k,ismpl)/delx(i)
+ END IF
+ IF (i>1) THEN
+ c(i,j,k,ismpl) = ti(i-1,j,k,ismpl)/delx(i)
+ END IF
+ END IF
+
+ IF (j0>1) THEN
+ IF (j<j0) THEN
+ f(i,j,k,ismpl) = tj(i,j,k,ismpl)/dely(j)
+ END IF
+ IF (j>1) THEN
+ b(i,j,k,ismpl) = tj(i,j-1,k,ismpl)/dely(j)
+ END IF
+ END IF
+
+ IF (k0>1) THEN
+ IF (k<k0) THEN
+ g(i,j,k,ismpl) = tk(i,j,k,ismpl)/delz(k)
+ END IF
+ IF (k>1) THEN
+ a(i,j,k,ismpl) = tk(i,j,k-1,ismpl)/delz(k)
+ END IF
+ END IF
+
+ d(i,j,k,ismpl) = -(e(i,j,k,ismpl)+c(i,j,k,ismpl)+f(i,j,k &
+ ,ismpl)+b(i,j,k,ismpl)+g(i,j,k,ismpl)+a(i,j,k,ismpl))
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+
+ RETURN
+ END
+
+!> @brief calculate right hand side for the head equation
+!> @param[in] ismpl local sample index
+!> @details
+!> calculate right hand side for the head equation\n
+!> coefficients are stored as vectors in the diagonals a-g (d center) and rhs in w.\n
+ SUBROUTINE set_hcoefrs(ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_flow
+ use mod_time
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+
+
+ DOUBLE PRECISION src, deltf, sijk
+ ! INTEGER c1, c2, c3, c4
+
+ DOUBLE PRECISION buoy, compf, compm, rhof, por, deltat, hstor, &
+ visf
+ EXTERNAL buoy, compf, compm, rhof, por, deltat, hstor, visf
+
+
+ deltf = deltat(simtime(ismpl),ismpl)
+
+! rhs: sources
+
+ IF (transient .AND. tr_switch(ismpl)) THEN
+! - - - - - - - - transient - - - - - - - - - - -
+ CALL omp_mvp(i0,j0,k0,headold(1,cgen_time,ismpl), &
+ x(1,1,1,ismpl),a(1,1,1,ismpl),b(1,1,1,ismpl), &
+ c(1,1,1,ismpl),d(1,1,1,ismpl),e(1,1,1,ismpl), &
+ f(1,1,1,ismpl),g(1,1,1,ismpl))
+
+!$OMP do schedule(static) collapse(3)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ src = 0.0D0
+! buoyancy
+ IF (k<k0) src = src + buoy(i,j,k,ismpl)/delz(k)
+ IF (k>1) src = src - buoy(i,j,k-1,ismpl)/delz(k)
+
+ sijk = hstor(i,j,k,ismpl)
+ d(i,j,k,ismpl) = d(i,j,k,ismpl) - sijk/(deltf*thetaf)
+ w(i,j,k,ismpl) = w(i,j,k,ismpl) - &
+ (1.0D0-thetaf)*x(i,j,k,ismpl) - &
+ sijk*headold(i+(j-1)*i0+(k-1)*i0*j0,cgen_time,ismpl) &
+ /deltf - src
+ w(i,j,k,ismpl) = w(i,j,k,ismpl)/thetaf
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+
+ ELSE
+! - - - - - - - - steady state - - - - - - - - - - - - - - - - - - - - -
+!$OMP do schedule(static) collapse(3)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ src = 0.0D0
+! buoyancy - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ IF (k<k0) src = src + buoy(i,j,k,ismpl)/delz(k)
+ IF (k>1) src = src - buoy(i,j,k-1,ismpl)/delz(k)
+ w(i,j,k,ismpl) = w(i,j,k,ismpl) - src
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+ END IF
+
+ RETURN
+ END
diff --git a/forward/head/set_hq.f90 b/forward/head/set_hq.f90
new file mode 100644
index 0000000..592e8ff
--- /dev/null
+++ b/forward/head/set_hq.f90
@@ -0,0 +1,64 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief modify coefficents for the head equation according to the prescribed sources and sinks
+!> @param[in] ismpl local sample index
+!> @details
+!> modify coefficents for the head equation according to the prescribed sources and sinks\n
+!> coefficients are stored as vectors in the diagonals a-g (d center) and rhs in w.\n
+ SUBROUTINE set_hq(ismpl)
+ use arrays
+ use mod_genrl
+ use mod_time
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION deltat, deltf, qf
+ EXTERNAL deltat, qf
+
+! rhs: sources
+ IF (transient .AND. tr_switch(ismpl)) THEN
+ deltf = deltat(simtime(ismpl),ismpl)
+!$OMP do schedule(static) collapse(3)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ w(i,j,k,ismpl) = w(i,j,k,ismpl) - qf(i,j,k,ismpl)
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+ ELSE
+!$OMP do schedule(static) collapse(3)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ w(i,j,k,ismpl) = w(i,j,k,ismpl) - qf(i,j,k,ismpl)
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+ END IF
+
+ RETURN
+ END
diff --git a/forward/input/calc_deltatime.f90 b/forward/input/calc_deltatime.f90
new file mode 100644
index 0000000..16baeb7
--- /dev/null
+++ b/forward/input/calc_deltatime.f90
@@ -0,0 +1,152 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief compute time steps table delta_time
+!> @param[in] ismpl local sample index
+!> @details
+!> Compute the time steps table delta time. \n\n
+!>
+!> Linear: dt(j) = (tend-tstart)/n \n\n
+!>
+!> Logarithmic: dt(j) = tunit * (10**(j/n*((tstart-tend)/tunit + 1)) -
+!> 1) \n\n
+!>
+!> Varied logarithmic (tstart needs to be non-zero): dt(j) = tstart *
+!> (10**(j/n * tend/tstart) - 10**((j-1)/n * tend/tstart)) \n\n
+!>
+!> Logarithmic decreasing: dt(j) = tunit *
+!> (10**((n-j)/n*((tstart-tend)/tunit + 1)) - 1) \n\n
+subroutine calc_deltatime(ismpl)
+
+ use arrays, only: delta_time
+ use mod_genrl, only: memory
+ use mod_time, only: nperiod, ntimestep, tunit, iperiod, dperiod
+
+ implicit none
+
+ ! local sample index
+ integer :: ismpl
+
+ ! Counter: overall time step
+ integer :: it
+
+ ! Number of time steps in current time periods
+ integer :: nstep
+
+ ! Counters: Period, time step of current period
+ integer :: iper, istep
+
+ ! Logarithmic factor, used in logarithmic time stepping
+ double precision :: facl
+
+ ! End (t1) and start (t0) time of time step
+ double precision :: t1, t0
+
+
+ ! Re-allocate delta_time to total number of time periods
+ deallocate(delta_time)
+ memory = memory - 1
+ allocate(delta_time(ntimestep))
+ memory = memory + ntimestep
+
+ ! Set intitial time period counter
+ it = 0
+
+ ! Loop over time periods
+ do iper = 1, nperiod
+
+ ! Number of time steps in current time periods
+ nstep = iperiod(iper,1)
+
+ ! Compute time steps according to type
+ if (iperiod(iper,2) == 1) then
+ ! type: linear
+
+ do istep = 1, nstep
+ it = it + 1
+ delta_time(it) = (dperiod(iper,2) - dperiod(iper,1)) / dble(nstep)
+ end do
+
+ else if (iperiod(iper,2) == 2) then
+ ! type: logarithmically increasing
+
+ facl = log10((dperiod(iper,2) - dperiod(iper,1))/tunit + 1.D0) / dble(nstep)
+
+ t0 = dperiod(iper,1)
+ do istep = 1, nstep
+ it = it + 1
+ t1 = dperiod(iper,1) + tunit * 10.0d0**(dble(istep) * facl) - tunit
+ delta_time(it) = t1 - t0
+ t0 = t1
+ end do
+
+ else if (iperiod(iper,2)==3) then
+ ! type: varied logarithmically increasing
+
+ if (dperiod(iper,1) <= 0.0d0) then
+ write(unit = *, fmt = *) 'error (read_time.f90): ',&
+ 'No varied Log with starting time 0.0d0'
+ stop 1
+ end if
+
+ facl = log10(dperiod(iper,2) / dperiod(iper,1)) / dble(nstep)
+
+ t0 = dperiod(iper,1)
+ do istep = 1, nstep
+ it = it + 1
+ t1 = dperiod(iper,1) * 10.0d0**(dble(istep) * facl)
+ delta_time(it) = t1 - t0
+ t0 = t1
+ end do
+
+ else if (iperiod(iper,2)==-2) then
+ ! type: logarithmically decreasing
+
+ facl = log10((dperiod(iper,2) - dperiod(iper,1))/tunit + 1.0d0) / dble(nstep)
+
+ t0 = dperiod(iper,2)
+ do istep = nstep - 1, 0, -1
+ it = it + 1
+ t1 = dperiod(iper,1) + tunit * 10.0d0**(dble(istep) * facl) - tunit
+ delta_time(it) = t0 - t1
+ t0 = t1
+ end do
+
+ else
+ write(*,'(1A,1I2,1A,1I2,1A)') &
+ 'error: wrong time step type ', iperiod(iper,2), ' at ', iper, &
+ ' in "read_time.f" !'
+ stop
+
+ end if
+
+ end do
+
+ ! Sanity check: Total number of time steps
+ if (it /= ntimestep) then
+ write(*,'(1A)') 'error: lost some time steps in "read_time.f" !'
+ stop
+ end if
+
+ return
+
+end subroutine calc_deltatime
diff --git a/forward/input/read_array.f90 b/forward/input/read_array.f90
new file mode 100644
index 0000000..9ee6d8b
--- /dev/null
+++ b/forward/input/read_array.f90
@@ -0,0 +1,87 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief read MM*NN double precision values from file
+!> @param[in] fid file id
+!> @param[out] AA array to fill
+!> @param[in] MM number of values expected in each line
+!> @param[in] NN number of lines
+!> @param[in] ustr section name
+!> @param[in] ismpl local sample index (ignored here)
+ SUBROUTINE read_array(fid,mm,nn,aa,ustr,ismpl)
+ use arrays
+ use mod_genrl
+ IMPLICIT NONE
+!
+ INTEGER mm, nn, i, j, ismpl
+! warning flag
+ LOGICAL w_flag
+! file id
+ INTEGER fid
+! array to fill
+ DOUBLE PRECISION aa(mm,nn)
+! unit string, for error message
+ character (len=*) :: ustr
+! for reading each line separated
+ character (len=1024) :: line
+
+ w_flag = .false.
+ IF (ustr==key_char//' units' .OR. &
+ ustr==key_char//' errors' .OR. &
+ ustr==key_char//' apriori') THEN
+ DO j = 1, nn
+ READ(fid,'(A)',err=200,end=200) line
+ READ(line,*,err=100,end=100) (aa(i,j),i=1,mm)
+ GOTO 10
+100 IF (i-1<mm) w_flag = .true.
+10 CONTINUE
+ END DO
+ IF (w_flag) GOTO 300
+ ELSE
+ DO j = 1, nn
+ READ(fid,*,err=200,end=200) (aa(i,j),i=1,mm)
+ END DO
+ ENDIF
+ RETURN
+!
+! error handler
+200 WRITE(*,'(3A,1I5,1A,1I5,1A)') 'error: while reading section "', ustr, &
+ '", to few values (need ', mm, ' in each of the ', nn, ' lines) !'
+ STOP
+300 WRITE(*,'(3A,1I5,1A,1I5,1A)') ' <D> : WARNING while reading section "', ustr, &
+ '", to few values (need ', mm, ' in each of the ', nn, ' lines) !'
+ IF (mm==nprop_load) THEN
+ IF (ustr==key_char//' units') WRITE(*,'(1I3,2A,'//c_npropunit//'(",",1A),1A)') mm, &
+ ' properties each line : [', (properties(i),i=1,nprop_load), ']'
+ IF (ustr==key_char//' errors') WRITE(*,'(1I3,2A,'//c_npropunit//'(",",1A),1A)') mm, &
+ ' property errors each line : [', (properties(i),i=1,nprop_load), ']'
+ IF (ustr==key_char//' apriori') WRITE(*,'(1I3,2A,'//c_npropunit//'(",",1A),1A)') &
+ mm, ' apriori values each line : [', (properties(i),i=1,nprop_load), ']'
+ WRITE(*,*) ' '
+ WRITE(*,'(1A)') ' properties:'
+ DO i = 1, nprop_load
+ WRITE(*,'(4A)') ' ', properties(i), ': ', doc_properties(i)
+ END DO
+ WRITE(*,*) ' '
+ END IF
+ RETURN
+ END
diff --git a/forward/input/read_bc.f90 b/forward/input/read_bc.f90
new file mode 100644
index 0000000..c8b7066
--- /dev/null
+++ b/forward/input/read_bc.f90
@@ -0,0 +1,839 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief read the boundary condition specifications
+!> @param[in] filen number of the opened file
+!> @param[in] line current character line
+!> @param[in] i_pv physical value / state variable - index
+!> @param[in] i_bt boundary type -index
+!> @param[in,out] posi number (position of the last one) of boundary points - before and after reading
+!> @param[out] ilost number of lost boundary points (reading ignored)
+!> @param[in] ismpl local sample index
+!> @details
+!> read model boundary points\n
+!> \n
+!> Note: To be able to use input file parsing with hdf5, the
+!> hdf5-input-files have to be generated using the script:
+!> `convert_to_hdf5.py`. This script can be found in the repository
+!> `SHEMAT-Suite_Scripts` under
+!> `python/preprocessing/convert_to_hdf5.py`.
+ SUBROUTINE read_bc(filen,line,i_pv,i_bt,posi,ilost,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_flow
+ use mod_temp
+ use mod_conc
+ use mod_linfos
+#ifndef noHDF
+ use mod_input_file_parser_hdf5
+#endif
+ IMPLICIT NONE
+ integer :: i, j, k
+ integer :: ismpl
+!
+! number of the opened file
+ INTEGER filen, posi, ilost, i_errors
+! i_bcu : bc-unit
+! i_bctp : bc-time period
+! i_pv : physical value index
+! i_bt : boundary type (dirichlet, neumann)
+! i_si : sub index (conc)
+! i_dir : direction
+! i_records: number of entries for this section
+ INTEGER i_bcu, i_bctp, i_pv, i_bt, i_si, i_dir, i_records
+! d_bcmy: bc-my
+ DOUBLE PRECISION d_bcmy
+
+ character (len=80) :: line
+
+ LOGICAL, ALLOCATABLE :: tmpbl(:,:,:,:)
+ INTEGER, ALLOCATABLE :: tmpind(:,:)
+ DOUBLE PRECISION, ALLOCATABLE :: tmpval(:,:)
+
+ INTEGER lblank, read_direction, i_b, i_e, j_b, j_e, k_b, k_e, ll
+ INTEGER level_bcindex
+
+ LOGICAL read_simple, read_bctp, read_species, read_bcval, &
+ l_errign
+ LOGICAL found, no_ext_link, no_ext_link_int
+ EXTERNAL found, no_ext_link, no_ext_link_int, lblank, &
+ read_direction
+
+ character (len=5), dimension (0:6) :: c_dir
+ DATA c_dir/'none', 'left', 'right', 'front', 'back', 'base', &
+ 'top'/
+ character (len=8) :: c_name
+ logical :: found_marker
+ character (len=80) :: full_bc_name
+
+! if switch used, read one column more (bcindex)
+ i_bcu = 0
+! 0: do not read bc-units, but read pv-values
+! 1: read bc-units
+! 2: do not read bc-units and pv-values
+ level_bcindex = 0
+#ifndef noHDF
+ if (h5parse_use_hdf5_datafile) then
+ full_bc_name = trim(line)
+ if (h5parse_check_attr_exist("bcindex","bc/i"//full_bc_name)) then
+ call h5parse_read_integer_attribute("bcindex",level_bcindex,"bc/i"//full_bc_name)
+ end if
+ else
+#endif
+ CALL get_arg('bcindex',line,i,j)
+ IF (i>=1 .AND. j>=i) THEN
+! prove "r" instead of "read"
+ IF (line(i:i)=='r') THEN
+ level_bcindex = 1
+ ELSE
+ level_bcindex = 2
+ READ(line(i:j),*) i_bcu
+! write(*,'(1A,1I5)') ' bc unit=',i_bcu
+ END IF
+ END IF
+#ifndef noHDF
+ end if
+#endif
+
+ d_bcmy = 1.0D+18
+#ifndef noHDF
+ if (h5parse_use_hdf5_datafile) then
+ if (h5parse_check_attr_exist("bcmy","bc/"//full_bc_name)) then
+ call h5parse_read_double_attribute("bcmy",d_bcmy,"bc/"//full_bc_name)
+ end if
+ else
+#endif
+ CALL get_arg('bcmy',line,i,j)
+ IF (i>=1 .AND. j>=i) THEN
+ READ(line(i:j),*) d_bcmy
+! write(*,'(1A,1e16.8)') ' bcmy=',d_bcmy
+ END IF
+#ifndef noHDF
+ end if
+#endif
+
+ i_si = 0
+ read_species = .FALSE.
+ IF (i_pv==pv_conc) read_species = .TRUE.
+#ifndef noHDF
+ if (h5parse_use_hdf5_datafile) then
+ if (h5parse_check_attr_exist("species","bc/i"//full_bc_name)) then
+ call h5parse_read_integer_attribute("species",i_si,"bc/i"//full_bc_name)
+ read_species = .FALSE.
+ end if
+ else
+#endif
+ CALL get_arg('species',line,i,j)
+ IF (i>=1 .AND. j>=i) THEN
+ READ(line(i:j),*) i_si
+ read_species = .FALSE.
+! write(*,'(1A,1I3)') ' speCies=',i_si
+ END IF
+#ifndef noHDF
+ end if
+#endif
+
+ i_bctp = 0
+ read_bctp = .TRUE.
+#ifndef noHDF
+ if (h5parse_use_hdf5_datafile) then
+ if (h5parse_check_attr_exist("bctp","bc/i"//full_bc_name)) then
+ call h5parse_read_integer_attribute("bctp",i_bctp,"bc/i"//full_bc_name)
+ read_bctp = .False.
+ end if
+ else
+#endif
+ CALL get_arg('bctp',line,i,j)
+ IF (i>=1 .AND. j>=i) THEN
+ READ(line(i:j),*) i_bctp
+ read_bctp = .FALSE.
+! write(*,'(1A,1I5)') ' bCtp=',i_bCtp
+ END IF
+#ifndef noHDF
+ end if
+#endif
+
+#ifndef noHDF
+ if (h5parse_use_hdf5_datafile) then
+ read_bcval = .not. h5parse_check_attr_exist("value","bc/i"//full_bc_name)
+ else
+#endif
+ read_bcval = .TRUE.
+ CALL get_arg('value',line,i,j)
+ IF (i>=1 .AND. j>=i) THEN
+! prove "i" instead of "init"
+ IF (line(i:i)=='i') THEN
+ read_bcval = .FALSE.
+ ELSE
+ WRITE(*,'(3A)') 'warning: option "value=', line(i:j), &
+ '" ignored.'
+ END IF
+ END IF
+#ifndef noHDF
+ end if
+#endif
+
+#ifndef noHDF
+ if (h5parse_use_hdf5_datafile) then
+ l_errign = h5parse_check_attr_exist("error","bc/i"//full_bc_name)
+ else
+#endif
+ l_errign = .FALSE.
+ CALL get_arg('error',line,i,j)
+ IF (i>=1 .AND. j>=i) THEN
+! prove "i" instead of "ignore"
+ IF (line(i:i)=='i') THEN
+ l_errign = .TRUE.
+ ELSE
+ WRITE(*,'(3A)') 'warning: option "error=', line(i:j), &
+ '" ignored.'
+ END IF
+ END IF
+#ifndef noHDF
+ end if
+#endif
+
+ i_dir = -1
+#ifndef noHDF
+ if (h5parse_use_hdf5_datafile) then
+ l_errign = h5parse_check_attr_exist("error","bc/i"//full_bc_name)
+ else
+#endif
+ read_simple = .FALSE.
+ CALL get_arg('simple',line,i,j)
+ IF (i>=1 .AND. j>=i) THEN
+ i_dir = read_direction(line(i:j))
+ read_simple = .TRUE.
+! enable "error=ignore" as default in <simple> case
+ l_errign = .TRUE.
+ END IF
+#ifndef noHDF
+ end if
+#endif
+
+#ifndef noHDF
+ if (h5parse_use_hdf5_datafile) then
+ if (h5parse_check_attr_exist("direction","bc/i"//full_bc_name)) then
+ call h5parse_read_integer_attribute("direction",i_dir,"bc/i"//full_bc_name)
+ end if
+ else
+#endif
+ CALL get_arg('direction',line,i,j)
+ IF (i>=1 .AND. j>=i) THEN
+ k = read_direction(line(i:j))
+ IF (i_dir==-1) THEN
+ i_dir = k
+!debug write(*,'(2A)') ' direCtion=',C_dir(i_dir)
+ ELSE IF (i_dir/=k) THEN
+ WRITE(*,'(1A)') 'error: "direction"-"simple" mismatch !'
+ STOP
+ END IF
+ END IF
+#ifndef noHDF
+ end if
+#endif
+
+! zero, should be forbidden !!!
+ i_dir = max(0,i_dir)
+#ifndef noHDF
+ if (h5parse_use_hdf5_datafile) then
+ i_records = h5parse_read_dimension_size_for_dataset("bc/"//full_bc_name)
+ else
+#endif
+ i_b = 1
+ i_e = i0
+ j_b = 1
+ j_e = j0
+ k_b = 1
+ k_e = k0
+ IF (read_simple) THEN
+ IF (i_dir==0) THEN
+ WRITE(*,*) 'error: simple=none not allowed !!!'
+ STOP
+ ELSE IF (i_dir==1) THEN
+ i_records = j0*k0
+ i_b = 1
+ i_e = 1
+ ELSE IF (i_dir==2) THEN
+ i_records = j0*k0
+ i_b = i0
+ i_e = i0
+ ELSE IF (i_dir==3) THEN
+ i_records = i0*k0
+ j_b = 1
+ j_e = 1
+ ELSE IF (i_dir==4) THEN
+ i_records = i0*k0
+ j_b = j0
+ j_e = j0
+ ELSE IF (i_dir==5) THEN
+ i_records = i0*j0
+ k_b = 1
+ k_e = 1
+ ELSE IF (i_dir==6) THEN
+ i_records = i0*j0
+ k_b = k0
+ k_e = k0
+ END IF
+ ELSE
+ CALL get_arg('records',line,i,j)
+ IF (i<1 .OR. j<i) THEN
+ READ(filen,*) i_records
+ ELSE
+ READ(line(i:j),*) i_records
+ END IF
+ END IF
+!debug write(*,'(1A,1I5)') ' reCords=',i_reCords
+#ifndef noHDF
+ end if
+#endif
+
+ ALLOCATE(tmpind(i_records,nibc))
+ ALLOCATE(tmpval(i_records,ndbc))
+
+found_marker = .false.
+#ifndef noHDF
+ if (h5parse_use_hdf5_datafile) then
+ call h5parse_read_2d_double_dataset("bc/"//full_bc_name,tmpval)
+ call h5parse_read_2d_integer_dataset("bc/i"//full_bc_name,tmpind)
+ found_marker = .true.
+ else
+#endif
+
+ c_name = pv_name(i_pv) // '_' // bc_name(i_bt)
+! sainty check
+ IF (i_pv==pv_conc .AND. i_si<1 .AND. .NOT. read_species) THEN
+ WRITE(*,'(1A)') 'error: "species" index invalid!'
+ STOP
+ END IF
+
+ IF (no_ext_link_int(i_records,nibc,1,tmpind,'i'//c_name,line) &
+ .AND. no_ext_link(i_records,ndbc,1,tmpval,c_name,line)) &
+ THEN
+ found_marker = .true.
+ IF (read_simple) THEN
+! e.g. [temp=10.d0]
+! need : bcindex = ?
+! bctp = ?
+! species = ?
+! simple = ? (direction)
+! bcmy = ?
+ IF (read_species) THEN
+ WRITE(*,'(1A)') 'error: "species" index missing!!!'
+ STOP
+ END IF
+ IF (level_bcindex==0 .AND. read_bcval) THEN
+ READ(filen,*,err=1001,end=1001) (tmpval(ll,1),ll=1, &
+ i_records)
+ ELSE IF (level_bcindex==2) THEN
+ DO ll = 1, i_records
+ tmpval(ll,1) = 0.D0
+ END DO
+ ELSE IF (level_bcindex==1) THEN
+ WRITE(*,'(1A)') 'error: when "simple=?", then "bcindex=read" not supported!!!'
+ STOP
+ END IF
+
+ ll = 0
+ DO k = k_b, k_e
+ DO j = j_b, j_e
+ DO i = i_b, i_e
+ ll = ll + 1
+ tmpind(ll,cbc_i) = i
+ tmpind(ll,cbc_j) = j
+ tmpind(ll,cbc_k) = k
+ tmpind(ll,cbc_bcu) = i_bcu
+ tmpind(ll,cbc_bctp) = i_bctp
+ tmpind(ll,cbc_pv) = i_pv
+ tmpind(ll,cbc_bt) = i_bt
+ tmpind(ll,cbc_si) = i_si
+ tmpind(ll,cbc_dir) = i_dir
+ tmpval(ll,2) = d_bcmy
+ END DO
+ END DO
+ END DO
+ ELSE
+! init, preset values
+ DO ll = 1, i_records
+ tmpind(ll,cbc_bcu) = i_bcu
+ tmpind(ll,cbc_bctp) = i_bctp
+ tmpind(ll,cbc_pv) = i_pv
+ tmpind(ll,cbc_bt) = i_bt
+ tmpind(ll,cbc_si) = i_si
+ tmpind(ll,cbc_dir) = i_dir
+ tmpval(ll,1) = 0.0D0
+ tmpval(ll,2) = d_bcmy
+ READ(filen,'(1A)',err=1000,end=1000) line
+! read, overwrite values
+ IF (level_bcindex==1 .AND. read_bctp .AND. read_species) &
+ THEN
+! e.g. [i=1,j=10,k=3, bc-unit=4, bctp-id=0, species=1]
+ READ(line,*,err=1002,end=1002) (tmpind(ll,j),j=1,3), &
+ tmpind(ll,cbc_bcu), tmpind(ll,cbc_bctp), &
+ tmpind(ll,cbc_si)
+ ELSE IF (level_bcindex==1 .AND. .NOT. read_bctp .AND. &
+ read_species) THEN
+! e.g. [i=1,j=10,k=3, bc-unit=4, species=1]
+ READ(line,*,err=1003,end=1003) (tmpind(ll,j),j=1,3), &
+ tmpind(ll,cbc_bcu), tmpind(ll,cbc_si)
+ ELSE IF (level_bcindex==1 .AND. read_bctp .AND. &
+ .NOT. read_species) THEN
+! e.g. [i=1,j=10,k=3, bc-unit=4, bctp-id=0]
+ READ(line,*,err=1004,end=1004) (tmpind(ll,j),j=1,3), &
+ tmpind(ll,cbc_bcu), tmpind(ll,cbc_bctp)
+ ELSE IF (level_bcindex==1 .AND. .NOT. read_bctp .AND. &
+ .NOT. read_species) THEN
+! e.g. [i=1,j=10,k=3, bc-unit=4]
+ READ(line,*,err=1005,end=1005) (tmpind(ll,j),j=1,3), &
+ tmpind(ll,cbc_bcu)
+ ELSE IF (level_bcindex==0 .AND. read_bctp .AND. &
+ read_species .AND. read_bcval) THEN
+! e.g. [i=1,j=10,k=3, temp=10.d0, bctp-id=0, species=1]
+ READ(line,*,err=1006,end=1006) (tmpind(ll,j),j=1,3), &
+ tmpval(ll,1), tmpind(ll,cbc_bctp), tmpind(ll,cbc_si)
+ ELSE IF (level_bcindex==0 .AND. .NOT. read_bctp .AND. &
+ read_species .AND. read_bcval) THEN
+! e.g. [i=1,j=10,k=3, temp=10.d0, species=1]
+ READ(line,*,err=1007,end=1007) (tmpind(ll,j),j=1,3), &
+ tmpval(ll,1), tmpind(ll,cbc_si)
+ ELSE IF (level_bcindex==0 .AND. read_bctp .AND. &
+ .NOT. read_species .AND. read_bcval) THEN
+! e.g. [i=1,j=10,k=3, temp=10.d0, bctp-id=0]
+ READ(line,*,err=1008,end=1008) (tmpind(ll,j),j=1,3), &
+ tmpval(ll,1), tmpind(ll,cbc_bctp)
+ ELSE IF (level_bcindex==0 .AND. .NOT. read_bctp .AND. &
+ .NOT. read_species .AND. read_bcval) THEN
+! e.g. [i=1,j=10,k=3, temp=10.d0]
+ READ(line,*,err=1009,end=1009) (tmpind(ll,j),j=1,3), &
+ tmpval(ll,1)
+ ELSE IF (level_bcindex==2 .AND. read_bctp .AND. &
+ read_species) THEN
+! e.g. [i=1,j=10,k=3, bctp-id=0, species=1]
+ READ(line,*,err=1010,end=1010) (tmpind(ll,j),j=1,3), &
+ tmpind(ll,cbc_bctp), tmpind(ll,cbc_si)
+ ELSE IF (level_bcindex==2 .AND. .NOT. read_bctp .AND. &
+ read_species) THEN
+! e.g. [i=1,j=10,k=3, species=1]
+ READ(line,*,err=1011,end=1011) (tmpind(ll,j),j=1,3), &
+ tmpind(ll,cbc_si)
+ ELSE IF (level_bcindex==2 .AND. read_bctp .AND. &
+ .NOT. read_species) THEN
+! e.g. [i=1,j=10,k=3, bctp-id=0]
+ READ(line,*,err=1012,end=1012) (tmpind(ll,j),j=1,3), &
+ tmpind(ll,cbc_bctp)
+ ELSE IF (level_bcindex==2 .AND. .NOT. read_bctp .AND. &
+ .NOT. read_species) THEN
+! e.g. [i=1,j=10,k=3]
+ READ(line,*,err=1013,end=1013) (tmpind(ll,j),j=1,3)
+ ELSE IF (level_bcindex==0 .AND. read_bctp .AND. &
+ read_species .AND. .NOT. read_bcval) THEN
+! e.g. [i=1,j=10,k=3, bctp-id=0, species=1]
+ READ(line,*,err=1014,end=1006) (tmpind(ll,j),j=1,3), &
+ tmpind(ll,cbc_bctp), tmpind(ll,cbc_si)
+ ELSE IF (level_bcindex==0 .AND. .NOT. read_bctp .AND. &
+ read_species .AND. .NOT. read_bcval) THEN
+! e.g. [i=1,j=10,k=3, species=1]
+ READ(line,*,err=1015,end=1007) (tmpind(ll,j),j=1,3), &
+ tmpind(ll,cbc_si)
+ ELSE IF (level_bcindex==0 .AND. read_bctp .AND. &
+ .NOT. read_species .AND. .NOT. read_bcval) THEN
+! e.g. [i=1,j=10,k=3, bctp-id=0]
+ READ(line,*,err=1016,end=1008) (tmpind(ll,j),j=1,3), &
+ tmpind(ll,cbc_bctp)
+ ELSE IF (level_bcindex==0 .AND. .NOT. read_bctp .AND. &
+ .NOT. read_species .AND. .NOT. read_bcval) THEN
+! e.g. [i=1,j=10,k=3]
+ READ(line,*,err=1017,end=1009) (tmpind(ll,j),j=1,3)
+ END IF
+ end do
+ end if
+ end if
+#ifndef noHDF
+ end if
+#endif
+
+ if (found_marker) then
+ found_marker = .false.
+ if (read_simple) then
+ do ll = 1, i_records
+ ! copy value, when "value=init" was speCified
+ IF ( .NOT. read_bcval) THEN
+ i = tmpind(ll,cbc_i)
+ j = tmpind(ll,cbc_j)
+ k = tmpind(ll,cbc_k)
+ IF (i_pv==pv_head) tmpval(ll,1) = head(i,j,k, ismpl)
+ IF (i_pv==pv_pres) tmpval(ll,1) = pres(i,j,k, ismpl)
+ IF (i_pv==pv_temp) tmpval(ll,1) = temp(i,j,k, ismpl)
+ IF (i_pv==pv_conc) tmpval(ll,1) = conc(i,j,k,i_si, ismpl)
+ END IF
+ end do
+ else
+ do ll = 1, i_records
+
+!
+! sanity checks
+! i,j,k index check
+ IF (tmpind(ll,cbc_i)<1 .OR. tmpind(ll,cbc_i)>i0 .OR. &
+ tmpind(ll,cbc_j)<1 .OR. tmpind(ll,cbc_j)>j0 .OR. &
+ tmpind(ll,cbc_k)<1 .OR. tmpind(ll,cbc_k)>k0) THEN
+ WRITE(*,'(1A,1I6,1A)') &
+ 'error: index out of range, at line ', ll, '!'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+ END IF
+! pv index check
+ IF (tmpind(ll,cbc_pv)<1 .OR. tmpind(ll,cbc_pv)>npv) THEN
+ WRITE(*,'(1A,1I6,1A)') 'error: physical value index out of range [1..3], at line ', ll, '!'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+ END IF
+! species index check
+ IF (tmpind(ll,cbc_si)<0 .OR. tmpind(ll,cbc_si)>ntrans) THEN
+ WRITE(*,'(1A,1I6,1A)') &
+ 'error: species index out of range, at line ', ll,'!'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+ END IF
+! direction index check
+ IF (tmpind(ll,cbc_dir)<0 .OR. tmpind(ll,cbc_dir)>6) THEN
+ WRITE(*,'(1A,1I6,1A)') 'error: direction index out of range [0..6], at line ', ll, '!'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+ END IF
+! wells - direction check
+ IF (tmpind(ll,cbc_dir)/=0 .AND. tmpind(ll,cbc_bt)==bt_neuw) THEN
+ WRITE(*,'(1A,1I6,1A)') 'error: well function needs direction index 0, at line ', ll, '!'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+ END IF
+! bc-type check
+ IF (tmpind(ll,cbc_bt)/=bt_diri .AND. &
+ tmpind(ll,cbc_bt)/=bt_neum .AND. &
+ tmpind(ll,cbc_bt)/=bt_neuw) THEN
+ WRITE(*,'(1A,1I6,1A)') &
+ 'error: BC type out of range [1..3], at line ', ll, '!'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+ END IF
+! bc time period (BCTP) check
+! For deeper BCTP checks, a proof for 'tmpind(ll,cbc_bctp)' may be a good idea,
+! but the time period table is needed and readed later -> check then !
+!
+! copy value, when "value=init" was speCified
+ IF ( .NOT. read_bcval) THEN
+ IF (tmpind(ll,cbc_pv)==pv_head) tmpval(ll,1) &
+ = head(tmpind(ll,cbc_i),tmpind(ll,cbc_j), &
+ tmpind(ll,cbc_k),ismpl)
+ IF (tmpind(ll,cbc_pv)==pv_pres) tmpval(ll,1) &
+ = pres(tmpind(ll,cbc_i),tmpind(ll,cbc_j), &
+ tmpind(ll,cbc_k),ismpl)
+ IF (tmpind(ll,cbc_pv)==pv_temp) tmpval(ll,1) &
+ = temp(tmpind(ll,cbc_i),tmpind(ll,cbc_j), &
+ tmpind(ll,cbc_k),ismpl)
+ IF (tmpind(ll,cbc_pv)==pv_conc) tmpval(ll,1) &
+ = conc(tmpind(ll,cbc_i),tmpind(ll,cbc_j), &
+ tmpind(ll,cbc_k),tmpind(ll,cbc_si),ismpl)
+ END IF
+ END DO
+ END IF
+ END IF
+
+! sanity check
+ ALLOCATE(tmpbl(I0,J0,K0,max(1,ntrans)))
+ CALL set_lval(I0*J0*K0*max(1,ntrans), .FALSE., tmpbl)
+! mark existing boundary points
+ DO i = 1, posi
+ IF (ibc_data(i,cbc_pv)==i_pv) THEN
+ tmpbl(ibc_data(i,cbc_i),ibc_data(i,cbc_j),ibc_data(i,cbc_k),max(1,ibc_data(i,cbc_si))) = .TRUE.
+ END IF
+ END DO
+! check for double definition of boundary points
+ IF (l_errign) THEN
+! generate 'ignore' warnings
+ i_errors = 0
+ DO j = 1, i_records
+ IF (tmpbl(tmpind(j,cbc_i),tmpind(j,cbc_j),tmpind(j,cbc_k),max(1,tmpind(j,cbc_si)))) THEN
+ IF (read_simple) THEN
+ i_errors = i_errors +1
+ ELSE
+ WRITE(*,'(1A,3I6,1A)') ' BC ignored at [', &
+ tmpind(j,cbc_i), tmpind(j,cbc_j), tmpind(j,cbc_k),']'
+ END IF
+ tmpind(j,cbc_pv) = -1
+ ilost = ilost + 1
+ END IF
+ END DO
+ IF (read_simple .AND. i_errors>0) THEN
+ WRITE(*,'(1A,1I6,1A)') ' ',i_errors," BC's ignored (SIMPLE mode)"
+ END IF
+ ELSE
+! generate errors
+ i_errors = 0
+ DO j = 1, i_records
+ IF (tmpbl(tmpind(j,cbc_i),tmpind(j,cbc_j),tmpind(j,cbc_k),max(1,tmpind(j,cbc_si)))) THEN
+ WRITE(*,'(1A,3(1X,1I4),1A,1I1,1A,1I3,1A)') &
+ ' double defined type at [', tmpind(j,cbc_i), tmpind(j,cbc_j), tmpind(j,cbc_k), &
+ ' ],type=', i_pv,',species=', tmpind(j,cbc_si),', (different BC type ?) !'
+ i_errors = i_errors +1
+ END IF
+ END DO
+ IF (i_errors.gt.0) THEN
+ WRITE(*,'(1A)') 'error: to many invalid declarations above!!!'
+ STOP
+ END IF
+ END IF
+ DEALLOCATE(tmpbl)
+!
+ DO i = 1, i_records
+ IF (tmpind(i,cbc_pv)>=0) THEN
+ posi = posi + 1
+ DO j = 1, nibc
+ ibc_data(posi,j) = tmpind(i,j)
+ END DO
+ DO j = 1, ndbc
+ dbc_data(posi,j,ismpl) = tmpval(i,j)
+ END DO
+! convert [MPa] into [Pa]
+ IF (ibc_data(posi,cbc_pv)==pv_pres .AND. read_bcval) &
+ dbc_data(posi,1,ismpl) = dbc_data(posi,1,ismpl)*pa_conv
+!
+ bc_maxunits = max(bc_maxunits,tmpind(i,cbc_bcu))
+ IF ((tmpind(i,cbc_bcu)>nunits) .OR. (tmpind(i, &
+ cbc_bcu)<0)) THEN
+ WRITE(*,'(1A,1I7,1A)') &
+ 'error: bc-unit number out of range, at line ', i, '!'
+ STOP
+ END IF
+ END IF
+ END DO
+!
+ WRITE(*,'(4A)',advance='NO') ' [R] : ', pv_name(i_pv), ' ', &
+ bc_name(i_bt)
+ IF (read_simple) THEN
+ WRITE(*,'(3A,1I6,1A)',advance='NO') ', simple=', &
+ c_dir(i_dir), ', (size=', i_records, ')'
+ ELSE
+ WRITE(*,'(3A,1I6)',advance='NO') ', direction=', &
+ c_dir(i_dir), ', records=', i_records
+ END IF
+ WRITE(*,'(1A,1e12.4)',advance='NO') ', bcmy=', d_bcmy
+ IF (level_bcindex==1) THEN
+ WRITE(*,'(1A)',advance='NO') ', bcindex=read'
+ END IF
+ IF (level_bcindex==2) THEN
+ WRITE(*,'(1A,1I4)',advance='NO') ', bcindex=', i_bcu
+ END IF
+ IF (i_bctp/=0) WRITE(*,'(1A,1I4)',advance='NO') ', bctp=', &
+ i_bctp
+ IF (i_si/=0) WRITE(*,'(1A,1I4)',advance='NO') ', species=', &
+ i_si
+ IF (l_errign) WRITE(*,'(1A)',advance='NO') ', error=ignore'
+ WRITE(*,'(1A,1I6,1A)') ', (offset=', posi - i_records + 1, &
+ ')'
+!
+
+ DEALLOCATE(tmpval)
+ DEALLOCATE(tmpind)
+!
+ RETURN
+
+! ERROR handler
+1000 WRITE(*,'(1A)') 'error: expect a BC data line'
+ STOP
+1001 WRITE(*,'(1A)') 'error: to few values - "simple=?" specified'
+ WRITE(*,'(1A)') ' expected: I0*J0*K0 x [bc-value]'
+ STOP
+1002 WRITE(*,'(1A)') &
+ 'error: to few values - "bcindex=read" specified'
+ WRITE(*,'(1A)') &
+ ' expected: records x [i,j,k,bc-unit,tpbc-id,species]'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+1003 WRITE(*,'(1A)') &
+ 'error: to few values - "bcindex=read,bctp=?" specified'
+ WRITE(*,'(1A)') &
+ ' expected: records x [i,j,k,bc-unit,species]'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+1004 WRITE(*,'(1A)') &
+ 'error: to few values - "bcindex=read,species=?" specified'
+ WRITE(*,'(1A)') &
+ ' expected: records x [i,j,k,bc-unit,tpbc-id]'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+1005 WRITE(*,'(1A)') 'error: to few values - "bcindex=read,bctp=?,species=?" specified'
+ WRITE(*,'(1A)') ' expected: records x [i,j,k,bc-unit]'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+1006 WRITE(*,'(1A)') 'error: to few values - no option specified'
+ WRITE(*,'(1A)') &
+ ' expected: records x [i,j,k,bc-value,tpbc-id,species]'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+1007 WRITE(*,'(1A)') 'error: to few values - "bctp=?" specified'
+ WRITE(*,'(1A)') &
+ ' expected: records x [i,j,k,bc-value,species]'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+1008 WRITE(*,'(1A)') &
+ 'error: to few values - "species=?" specified'
+ WRITE(*,'(1A)') &
+ ' expected: records x [i,j,k,bc-value,tpbc-id]'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+1009 WRITE(*,'(1A)') &
+ 'error: to few values - "bctp=?,species=?" specified'
+ WRITE(*,'(1A)') ' expected: records x [i,j,k,bc-value]'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+1010 WRITE(*,'(1A)') &
+ 'error: to few values - "bcindex=?" specified'
+ WRITE(*,'(1A)') &
+ ' expected: records x [i,j,k,tpbc-id,species]'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+1011 WRITE(*,'(1A)') &
+ 'error: to few values - "bcindex=?,bctp=?" specified'
+ WRITE(*,'(1A)') ' expected: records x [i,j,k,species]'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+1012 WRITE(*,'(1A)') &
+ 'error: to few values - "bcindex=?,species=?" specified'
+ WRITE(*,'(1A)') ' expected: records x [i,j,k,tpbc-id]'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+1013 WRITE(*,'(1A)') 'error: to few values - "bcindex=?,bctp=?,species=?" specified'
+ WRITE(*,'(1A)') ' expected: records x [i,j,k]'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+1014 WRITE(*,'(1A)') &
+ 'error: to few values - "value=init" specified'
+ WRITE(*,'(1A)') &
+ ' expected: records x [i,j,k,tpbc-id,species]'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+1015 WRITE(*,'(1A)') &
+ 'error: to few values - "value=init,bctp=?" specified'
+ WRITE(*,'(1A)') ' expected: records x [i,j,k,species]'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+1016 WRITE(*,'(1A)') &
+ 'error: to few values - "value=init,species=?" specified'
+ WRITE(*,'(1A)') ' expected: records x [i,j,k,tpbc-id]'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+1017 WRITE(*,'(1A)') 'error: to few values - "value=init,bctp=?,species=?" specified'
+ WRITE(*,'(1A)') ' expected: records x [i,j,k]'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+ END
+
+!> @brief sort the boundary points, physical value order
+!> @param[in] ismpl local sample index
+!> @details
+!>sort the boundary points, physical value order\n
+ SUBROUTINE sort_bc(ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_flow
+ use mod_temp
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: i, j
+ integer :: ismpl
+ INTEGER, ALLOCATABLE :: tmpind(:,:)
+ DOUBLE PRECISION, ALLOCATABLE :: tmpval(:,:)
+
+
+ ALLOCATE(tmpind(nbc_data,nibc))
+ ALLOCATE(tmpval(nbc_data,ndbc))
+
+ first_flow = nbc_data + 1
+ last_flow = 0
+ IF (head_active .OR. pres_active) THEN
+ DO i = 1, nbc_data
+ IF (ibc_data(i,cbc_pv)==pv_head.OR.ibc_data(i,cbc_pv)==pv_pres) THEN
+ last_flow = last_flow + 1
+ first_flow = min(first_flow,last_flow)
+ DO j = 1, nibc
+ tmpind(last_flow,j) = ibc_data(i,j)
+ END DO
+ DO j = 1, ndbc
+ tmpval(last_flow,j) = dbc_data(i,j,ismpl)
+ END DO
+ END IF
+ END DO
+ END IF
+
+ first_temp = nbc_data + 1
+ last_temp = last_flow
+ IF (temp_active) THEN
+ DO i = 1, nbc_data
+ IF (ibc_data(i,cbc_pv)==pv_temp) THEN
+ last_temp = last_temp + 1
+ first_temp = min(first_temp,last_temp)
+ DO j = 1, nibc
+ tmpind(last_temp,j) = ibc_data(i,j)
+ END DO
+ DO j = 1, ndbc
+ tmpval(last_temp,j) = dbc_data(i,j,ismpl)
+ END DO
+ END IF
+ END DO
+ END IF
+
+ first_conc = nbc_data + 1
+ last_conc = last_temp
+ IF (trans_active) THEN
+ DO i = 1, nbc_data
+ IF (ibc_data(i,cbc_pv)==pv_conc) THEN
+ last_conc = last_conc + 1
+ first_conc = min(first_conc,last_conc)
+ DO j = 1, nibc
+ tmpind(last_conc,j) = ibc_data(i,j)
+ END DO
+ DO j = 1, ndbc
+ tmpval(last_conc,j) = dbc_data(i,j,ismpl)
+ END DO
+ END IF
+ END DO
+ END IF
+
+! copy back sorted values
+ DO j = 1, nibc
+ DO i = 1, nbc_data
+ ibc_data(i,j) = tmpind(i,j)
+ END DO
+ END DO
+ DO j = 1, ndbc
+ DO i = 1, nbc_data
+ dbc_data(i,j,ismpl) = tmpval(i,j)
+ END DO
+ END DO
+
+ DEALLOCATE(tmpval)
+ DEALLOCATE(tmpind)
+
+ RETURN
+ END
diff --git a/forward/input/read_check.f90 b/forward/input/read_check.f90
new file mode 100644
index 0000000..68aee85
--- /dev/null
+++ b/forward/input/read_check.f90
@@ -0,0 +1,295 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief check parameter / section - definition
+!> @param[in] filename model file name
+ SUBROUTINE read_check(filename)
+ use mod_genrl
+ IMPLICIT NONE
+ integer :: k
+ character (len=80) :: filename
+ character (len=80) :: line
+ LOGICAL phi_style
+ INTEGER ifil, locstr, f_entry, lblank, line_count
+ EXTERNAL locstr, lblank
+ INTEGER i_default
+ INTEGER (kind=8) :: i_64, test
+! Integer compatibility test for BLAS and LAPACK
+! both must be from the same size as the default integer size
+ i_default = 131072
+ i_64 = 131072
+ i_default = i_default*i_default
+ i_64 = i_64*i_64
+ IF (i_default==i_64) THEN
+ test = 0
+#ifdef BLAS32
+ test = 1
+#endif
+#ifdef LAPACK32
+ test = 1
+#endif
+ IF (test==1) THEN
+ WRITE(*,'(2A)') 'Integer compatibility test for', &
+ ' BLAS and LAPACK library: [failure]'
+ WRITE(*,*) &
+ 'Please determine the current integer size type'
+ WRITE(*,*) ' of your BLAS and LAPACK library, both must'
+ WRITE(*,*) &
+ ' have the same size and equal to the one used'
+ WRITE(*,*) ' by the compiler for this program binary !'
+ STOP
+ END IF
+ END IF
+ WRITE(*,*)
+ WRITE(*,*) ' checking input definitions:'
+ WRITE(*,*) ' from file "', filename(:lblank(filename)), &
+ '"'
+! init counter for hard errors (old style - not longer supported)
+ k = 0
+! read file
+ phi_style = .FALSE.
+ ifil = 77
+ line_count = 0
+ OPEN(ifil,file=filename,status='old')
+10 CONTINUE
+ READ(ifil,'(A)',end=20) line
+ line_count = line_count + 1
+ IF (line(1:1)/='#') GO TO 10
+ f_entry = 0
+! forward, general
+ f_entry = f_entry + locstr(line,key_char//' title')
+ f_entry = f_entry + locstr(line,key_char//' PROPS')
+ f_entry = f_entry + locstr(line,key_char//' USER')
+ f_entry = f_entry + locstr(line,key_char//' linfo')
+ f_entry = f_entry + locstr(line,key_char//' runmode')
+ f_entry = f_entry + locstr(line,key_char//' grid')
+ f_entry = f_entry + locstr(line,key_char//' nlsolve')
+ f_entry = f_entry + locstr(line,key_char//' active')
+ f_entry = f_entry + locstr(line,key_char//' rref')
+ f_entry = f_entry + locstr(line,key_char//' grav')
+ f_entry = f_entry + locstr(line,key_char//' rhocm')
+ f_entry = f_entry + locstr(line,key_char//' hpf')
+ f_entry = f_entry + locstr(line,key_char//' delx')
+ f_entry = f_entry + locstr(line,key_char//' dely')
+ f_entry = f_entry + locstr(line,key_char//' delz')
+ f_entry = f_entry + locstr(line,key_char//' uindex')
+ f_entry = f_entry + locstr(line,key_char//' units')
+ f_entry = f_entry + locstr(line,key_char//' bcunits')
+ f_entry = f_entry + locstr(line,key_char//' split units')
+! forward, output
+ f_entry = f_entry + locstr(line,key_char//' borehole log')
+ f_entry = f_entry + locstr(line,key_char//' disable small output')
+ f_entry = f_entry + locstr(line,key_char//' disable output')
+ f_entry = f_entry + locstr(line,key_char//' write output')
+ f_entry = f_entry + locstr(line,key_char//' read output')
+! forward, data
+ f_entry = f_entry + locstr(line,key_char//' data')
+! solver, convergency, flow
+ f_entry = f_entry + locstr(line,key_char//' lsolvef')
+ f_entry = f_entry + locstr(line,key_char//' error lsolvef')
+ f_entry = f_entry + locstr(line,key_char//' maxiter lsolvef')
+ f_entry = f_entry + locstr(line,key_char//' name lsolvef')
+ f_entry = f_entry + locstr(line,key_char//' criteria lsolvef')
+ f_entry = f_entry + locstr(line,key_char//' precondition lsolvef')
+ f_entry = f_entry + locstr(line,key_char//' omf')
+ f_entry = f_entry + locstr(line,key_char//' nliterf')
+ f_entry = f_entry + locstr(line,key_char//' grad nliterf')
+! solver, convergency, temperature
+ f_entry = f_entry + locstr(line,key_char//' lsolvet')
+ f_entry = f_entry + locstr(line,key_char//' error lsolvet')
+ f_entry = f_entry + locstr(line,key_char//' maxiter lsolvet')
+ f_entry = f_entry + locstr(line,key_char//' name lsolvet')
+ f_entry = f_entry + locstr(line,key_char//' criteria lsolvet')
+ f_entry = f_entry + locstr(line,key_char//' precondition lsolvet')
+ f_entry = f_entry + locstr(line,key_char//' omt')
+ f_entry = f_entry + locstr(line,key_char//' nlitert')
+ f_entry = f_entry + locstr(line,key_char//' grad nlitert')
+! solver, convergency, concentration
+ f_entry = f_entry + locstr(line,key_char//' lsolvec')
+ f_entry = f_entry + locstr(line,key_char//' error lsolvec')
+ f_entry = f_entry + locstr(line,key_char//' maxiter lsolvec')
+ f_entry = f_entry + locstr(line,key_char//' name lsolvec')
+ f_entry = f_entry + locstr(line,key_char//' criteria lsolvec')
+ f_entry = f_entry + locstr(line,key_char//' precondition lsolvec')
+ f_entry = f_entry + locstr(line,key_char//' nliterc')
+ f_entry = f_entry + locstr(line,key_char//' grad nliterc')
+! debug special
+#ifdef DEBUG
+ f_entry = f_entry + locstr(line,key_char//' debug output times')
+#endif
+!
+! forward, state variables
+ f_entry = f_entry + locstr(line,key_char//' head init')
+ f_entry = f_entry + locstr(line,key_char//' temp init')
+ f_entry = f_entry + locstr(line,key_char//' pres init')
+! forward, boundary conditions
+ f_entry = f_entry + locstr(line,key_char//' head bcd')
+ f_entry = f_entry + locstr(line,key_char//' head bcn')
+ f_entry = f_entry + locstr(line,key_char//' pres bcd')
+ f_entry = f_entry + locstr(line,key_char//' pres bcn')
+ f_entry = f_entry + locstr(line,key_char//' temp bcd')
+ f_entry = f_entry + locstr(line,key_char//' temp bcn')
+ f_entry = f_entry + locstr(line,key_char//' conc bcd')
+ f_entry = f_entry + locstr(line,key_char//' conc bcn')
+! forward, time
+ f_entry = f_entry + locstr(line,key_char//' timestep control')
+ f_entry = f_entry + locstr(line,key_char//' tunit')
+ f_entry = f_entry + locstr(line,key_char//' tstart')
+ f_entry = f_entry + locstr(line,key_char//' titer')
+ f_entry = f_entry + locstr(line,key_char//' time periods')
+ f_entry = f_entry + locstr(line,key_char//' bc time periods')
+ f_entry = f_entry + locstr(line,key_char//' monitor')
+ f_entry = f_entry + locstr(line,key_char//' output times')
+ f_entry = f_entry + locstr(line,key_char//' file output')
+! transport (chemical)
+ f_entry = f_entry + locstr(line,key_char//' ntrans')
+ f_entry = f_entry + locstr(line,key_char//' tracer')
+ f_entry = f_entry + locstr(line,key_char//' transpar')
+! simulation
+ f_entry = f_entry + locstr(line,key_char//' simulate')
+ f_entry = f_entry + locstr(line,key_char//' samples')
+ f_entry = f_entry + locstr(line,key_char//' parameter group')
+! ENKF
+ f_entry = f_entry + locstr(line,key_char//' enkf postcompute')
+ f_entry = f_entry + locstr(line,key_char//' enkf iter')
+! AD deterministic inverse
+ f_entry = f_entry + locstr(line,key_char//' inverse')
+ f_entry = f_entry + locstr(line,key_char//' enable property')
+ f_entry = f_entry + locstr(line,key_char//' enable unit')
+! inverse, property units
+ f_entry = f_entry + locstr(line,key_char//' errors')
+ f_entry = f_entry + locstr(line,key_char//' apriori')
+ f_entry = f_entry + locstr(line,key_char//' weight property')
+ f_entry = f_entry + locstr(line,key_char//' optimize property')
+! inverse, boundary conditions
+ f_entry = f_entry + locstr(line,key_char//' bcerrors')
+ f_entry = f_entry + locstr(line,key_char//' bcapriori')
+ f_entry = f_entry + locstr(line,key_char//' weight bc')
+ f_entry = f_entry + locstr(line,key_char//' optimize bc')
+! inverse, time
+ f_entry = f_entry + locstr(line,key_char//' tperrors')
+ f_entry = f_entry + locstr(line,key_char//' tpapriori')
+ f_entry = f_entry + locstr(line,key_char//' optimize tp')
+! inverse, weighting
+!AW f_entry = f_entry + locstr(line,key_char//' weight tp')
+ f_entry = f_entry + locstr(line,key_char//' weight para')
+ f_entry = f_entry + locstr(line,key_char//' weight data')
+! --------
+!
+! automatic generated check sections, by Makfile 'check_section'
+ f_entry = f_entry + locstr(line,key_char//' set')
+ f_entry = f_entry + locstr(line,key_char//' velocity')
+ f_entry = f_entry + locstr(line,key_char//' mfd')
+ f_entry = f_entry + locstr(line,key_char//' h5parse data file')
+ f_entry = f_entry + locstr(line,key_char//' simtime')
+ f_entry = f_entry + locstr(line,key_char//' jacoby')
+ f_entry = f_entry + locstr(line,key_char//' itimestep')
+ f_entry = f_entry + locstr(line,key_char//' iter_inv')
+ f_entry = f_entry + locstr(line,key_char//' variable step size')
+ f_entry = f_entry + locstr(line,key_char//' nliters')
+ f_entry = f_entry + locstr(line,key_char//' grad nliters')
+ f_entry = f_entry + locstr(line,key_char//' cindex')
+ f_entry = f_entry + locstr(line,key_char//' simul')
+ f_entry = f_entry + locstr(line,key_char//' enkf')
+ f_entry = f_entry + locstr(line,key_char//' prop limit')
+ f_entry = f_entry + locstr(line,key_char//' ilu block size')
+ f_entry = f_entry + locstr(line,key_char//' ZETA')
+ f_entry = f_entry + locstr(line,key_char//' THETA')
+ f_entry = f_entry + locstr(line,key_char//' PSI')
+ f_entry = f_entry + locstr(line,key_char//' LAMDA')
+ f_entry = f_entry + locstr(line,key_char//' C0')
+ f_entry = f_entry + locstr(line,key_char//' B2')
+ f_entry = f_entry + locstr(line,key_char//' B1')
+ f_entry = f_entry + locstr(line,key_char//' B0')
+ f_entry = f_entry + locstr(line,key_char//' species')
+ f_entry = f_entry + locstr(line,key_char//' secondary')
+ f_entry = f_entry + locstr(line,key_char//' sec_comp')
+ f_entry = f_entry + locstr(line,key_char//' parameter species')
+ f_entry = f_entry + locstr(line,key_char//' minerals')
+ f_entry = f_entry + locstr(line,key_char//' kinetic rate laws')
+ f_entry = f_entry + locstr(line,key_char//' inhibitors')
+ f_entry = f_entry + locstr(line,key_char//' subsample')
+ f_entry = f_entry + locstr(line,key_char//' bc standard deviation')
+ f_entry = f_entry + locstr(line,key_char//' bc group')
+ f_entry = f_entry + locstr(line,key_char//' regular')
+ f_entry = f_entry + locstr(line,key_char//' standard deviation')
+ f_entry = f_entry + locstr(line,key_char//' covar prior para')
+ f_entry = f_entry + locstr(line,key_char//' covar prior data')
+ f_entry = f_entry + locstr(line,key_char//' fluid props')
+ f_entry = f_entry + locstr(line,key_char//' archie')
+ f_entry = f_entry + locstr(line,key_char//' gas props')
+ f_entry = f_entry + locstr(line,key_char//' rhod')
+ f_entry = f_entry + locstr(line,key_char//' liq init')
+ f_entry = f_entry + locstr(line,key_char//' freeze_b')
+ f_entry = f_entry + locstr(line,key_char//' freeze_a')
+ f_entry = f_entry + locstr(line,key_char//' k_freeze')
+ f_entry = f_entry + locstr(line,key_char//' fracpar')
+! --------
+ IF (f_entry==0) WRITE(*,'(A,I6,3A)') 'warning: ignore line ', &
+ line_count, ': "', line(:lblank(line)), '"'
+! compatibility check
+ IF (locstr(line,key_char//' phi')==1) phi_style = .TRUE.
+! !!! no longer supported section, stoping later !!!
+ k = k + locstr(line,key_char//' left head')
+ k = k + locstr(line,key_char//' left flow')
+ k = k + locstr(line,key_char//' right head')
+ k = k + locstr(line,key_char//' right flow')
+ k = k + locstr(line,key_char//' front head')
+ k = k + locstr(line,key_char//' front flow')
+ k = k + locstr(line,key_char//' back head')
+ k = k + locstr(line,key_char//' back flow')
+ k = k + locstr(line,key_char//' base head')
+ k = k + locstr(line,key_char//' base flow')
+ k = k + locstr(line,key_char//' top head')
+ k = k + locstr(line,key_char//' top flow')
+ k = k + locstr(line,key_char//' left temperature')
+ k = k + locstr(line,key_char//' left heat flow')
+ k = k + locstr(line,key_char//' right temperature')
+ k = k + locstr(line,key_char//' right heat flow')
+ k = k + locstr(line,key_char//' front temperature')
+ k = k + locstr(line,key_char//' front heat flow')
+ k = k + locstr(line,key_char//' back temperature')
+ k = k + locstr(line,key_char//' back heat flow')
+ k = k + locstr(line,key_char//' base temperature')
+ k = k + locstr(line,key_char//' base heat flow')
+ k = k + locstr(line,key_char//' top temperature')
+ k = k + locstr(line,key_char//' top heat flow')
+ GO TO 10
+! close project config file
+20 CLOSE(ifil)
+ IF (k>0) THEN
+ WRITE(*,'(1A)') &
+ 'error: old BC sections no longer supported!!!'
+ STOP
+ END IF
+! compatibility check fails, then message out
+ IF (phi_style) THEN
+ WRITE(*,*)
+ WRITE(*,'(1A)') &
+ 'error: found old "PHI" style definitions !!!'
+ WRITE(*,'(1A)') &
+ ' Please change all "phi" into "head" occurrence !'
+ WRITE(*,*)
+ STOP
+ END IF
+ RETURN
+ END
diff --git a/forward/input/read_control.f90 b/forward/input/read_control.f90
new file mode 100644
index 0000000..7a17b05
--- /dev/null
+++ b/forward/input/read_control.f90
@@ -0,0 +1,79 @@
+
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief read control sections for the external file-infrastructure
+!> @param[in] filename
+!> @param[in] ismpl local sample index
+ SUBROUTINE read_control(filename,ismpl)
+ use mod_genrl
+ use mod_genrlc
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j
+
+ character (len=*) :: filename
+ character (len=5000) :: line
+ LOGICAL found
+ EXTERNAL found
+ INTRINSIC trim
+
+! External input file switch not set
+ if (.not. read_external_input) then
+ filename_data = filename
+ return
+ end if
+
+! open file
+ OPEN(79,file=filename,status='old')
+ WRITE(*,*) ' '
+ WRITE(*,*) ' reading external file control'
+ WRITE(*,*) ' '
+!
+ filename_data = filename
+ IF (runmode>=1) THEN
+ IF (found(79,key_char//' data: external file',line,.FALSE.)) THEN
+ CALL get_arg('file',line,i,j)
+ IF (i<1 .OR. j<i) THEN
+ READ(79,*,err=100,end=100) filename_data
+ ELSE
+ READ(line(i:j),*) filename_data
+ END IF
+ WRITE(*,*) ' [R] : external file "'//trim(filename_data)//'" for DATA'
+! ELSE
+! WRITE(*,*) ' <D> : no external file for DATA'
+ END IF
+ END IF
+!
+ CLOSE(79)
+ RETURN
+!
+! error handling
+100 WRITE(*,'(1A)') 'error: no external file name found in section "data: external file"!'
+ STOP
+101 WRITE(*,'(1A)') 'error: no external file name found in section "simul: external file"!'
+ STOP
+102 WRITE(*,'(1A)') 'error: no external file name found in section "enkf: external file"!'
+ STOP
+103 WRITE(*,'(1A)') 'error: no external file name found in section "inverse: external file"!'
+ STOP
+ END
diff --git a/forward/input/read_data.f90 b/forward/input/read_data.f90
new file mode 100644
index 0000000..b48c0a6
--- /dev/null
+++ b/forward/input/read_data.f90
@@ -0,0 +1,656 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief read observed data and allocate fields
+!> @param[in] filename file name
+!> @param[in] ismpl local sample index
+!> @details
+!> details see in documentation "read_observed_data.pdf"\n
+ SUBROUTINE read_data(filename,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_flow
+ use mod_temp
+ use mod_time
+ use mod_conc
+ use mod_data
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k, l
+ character (len=80) :: filename
+ character (len=80) :: line
+ INTEGER locstr, lblank, type, ozone, i2, i3, ll, &
+ ndata_sections, tmplen
+ ! INTEGER c_i, c_j, c_k
+ INTEGER level_timer, i_si, i_obs
+ DOUBLE PRECISION d_timer
+ LOGICAL found, no_ext_link, no_ext_link_int
+ ! LOGICAL incomp_bc
+ LOGICAL read_species, read_obs, read_absolute
+ INTEGER, ALLOCATABLE :: tmp_idata(:,:)
+ DOUBLE PRECISION, ALLOCATABLE :: tmp_data(:,:)
+ EXTERNAL locstr, found, no_ext_link, no_ext_link_int, lblank
+
+
+! read file
+ OPEN(79,file=filename,status='old')
+
+! init HDF5 support, when available
+ CALL open_hdf5(' ')
+
+ WRITE(*,*)
+ WRITE(*,*) ' reading observed data'
+ WRITE(*,*) ' from file "', filename(:lblank(filename)), &
+ '"'
+ WRITE(*,*)
+
+! init counter
+ ndata_h = 0
+ ndata_t = 0
+ ndata_c = 0
+ ndata_p = 0
+ ndata_s = 0
+ ndata_b = 0
+
+! count the number of observed data entries (sections and entries)
+ REWIND 79
+ ndata_sections = 0
+ ndata = 0
+
+10 READ(79,'(1A)',end=11) line
+ i = locstr(line,key_char//' data')
+! data line?
+ IF (i==1) THEN
+! increase number of sections
+ ndata_sections = ndata_sections + 1
+ CALL get_arg('records',line,i,j)
+ IF (i<1 .OR. j<i) THEN
+ READ(79,*) tmplen
+ ELSE
+ READ(line(i:j),*) tmplen
+ END IF
+! increase number of entries
+ ndata = ndata + tmplen
+ END IF
+! read next line, up to the end of file
+ GO TO 10
+
+! restart file
+11 REWIND 79
+
+ ALLOCATE(tmp_idata(max(ndata,1),n_idata))
+ ALLOCATE(tmp_data(max(ndata,1),n_ddata))
+ ll = 0
+
+ DO i3 = 1, ndata_sections
+ IF (found(79,key_char//' data',line,.TRUE.)) THEN
+ CALL get_arg('records',line,i,j)
+ IF (i<1 .OR. j<i) THEN
+ READ(79,*) tmplen
+ ELSE
+ READ(line(i:j),*) tmplen
+ END IF
+
+! time dependent data, if switch used, read one column more
+ d_timer = max_simtime/tunit
+! 0: do not read timers
+! 1: read timers
+! 2: use the given timer for all records
+ level_timer = 0
+ CALL get_arg('timer',line,i,j)
+ IF (i>=1 .AND. j>=i) THEN
+! prove "r" instead of "read"
+ IF (line(i:i)=='r') THEN
+ level_timer = 1
+ ELSE
+ level_timer = 2
+ READ(line(i:j),*,err=901) d_timer
+! write(*,'(1A,1e16.8)') ' timer=',d_timer
+ END IF
+ END IF
+
+! species for concentration
+ i_si = 0
+ read_species = .TRUE.
+ CALL get_arg('species',line,i,j)
+ IF (i>=1 .AND. j>=i) THEN
+ READ(line(i:j),*) i_si
+ read_species = .FALSE.
+! write(*,'(1A,1I3)') ' speCies=',i_si
+ END IF
+
+! position type
+ read_absolute = .FALSE.
+ CALL get_arg('pos',line,i,j)
+ IF (i>=1 .AND. j>=i) THEN
+! if (line(i:i).eq.'index') read_absolute = .false.
+! instead of prove "abs" or "index"
+ IF (line(i:i)=='a') read_absolute = .TRUE.
+! write(*,*) ' position absolute=',read_absolute
+ END IF
+
+! observation point index
+ i_obs = 0
+ read_obs = .TRUE.
+ CALL get_arg('obs',line,i,j)
+ IF (i>=1 .AND. j>=i) THEN
+ READ(line(i:j),*) i_obs
+ read_obs = .FALSE.
+! write(*,'(1A,1I3)') ' obs=',i_obs
+ END IF
+
+ WRITE(*,'(A,I6)') ' [R] : observed data nodes, records=' &
+ , tmplen
+! sanity check
+ IF (level_timer>=1 .AND. .NOT. transient) THEN
+ WRITE(*,'(2A)') &
+ 'error: "timer" is specified for the data', &
+ ' input, but the model is steady state !'
+ STOP
+ END IF
+
+ IF (no_ext_link_int(tmplen,n_idata,1,tmp_idata,'idata', &
+ line) .OR. no_ext_link(tmplen,n_ddata,1,tmp_data, &
+ 'data',line)) THEN
+ DO j = 1, tmplen
+! record counter
+ ll = ll + 1
+ READ(79,'(1A)') line
+ tmp_data(ll,cdd_time) = d_timer
+ tmp_idata(ll,cid_si) = i_si
+ tmp_idata(ll,cid_obs) = i_obs
+
+! ----------
+ IF ( .NOT. read_absolute) THEN
+! index position
+ IF (level_timer==1 .AND. read_obs) THEN
+ READ(line,*,err=1001,end=1001) tmp_data(ll, &
+ cdd_pv), tmp_data(ll,cdd_w), &
+ tmp_data(ll,cdd_time), (tmp_idata(ll,k),k=cid_i, &
+ cid_k), tmp_idata(ll,cid_pv), &
+ tmp_idata(ll,cid_obs)
+! re-read with sub-index (species)
+ IF (tmp_idata(ll,cid_pv)==pv_conc .AND. &
+ read_species) READ(line,*,err=1002,end=1002) &
+ tmp_data(ll,cdd_pv), tmp_data(ll,cdd_w), &
+ tmp_data(ll,cdd_time), (tmp_idata(ll,k),k=cid_i, &
+ cid_k), tmp_idata(ll,cid_pv), &
+ tmp_idata(ll,cid_si), tmp_idata(ll,cid_obs)
+ ELSE IF (level_timer==1 .AND. .NOT. read_obs) THEN
+ READ(line,*,err=1003,end=1003) tmp_data(ll, &
+ cdd_pv), tmp_data(ll,cdd_w), &
+ tmp_data(ll,cdd_time), (tmp_idata(ll,k),k=cid_i, &
+ cid_k), tmp_idata(ll,cid_pv)
+! re-read with sub-index (species)
+ IF (tmp_idata(ll,cid_pv)==pv_conc .AND. &
+ read_species) READ(line,*,err=1004,end=1004) &
+ tmp_data(ll,cdd_pv), tmp_data(ll,cdd_w), &
+ tmp_data(ll,cdd_time), (tmp_idata(ll,k),k=cid_i, &
+ cid_k), tmp_idata(ll,cid_pv), &
+ tmp_idata(ll,cid_si)
+ ELSE IF (level_timer/=1 .AND. read_obs) THEN
+ READ(line,*,err=1005,end=1005) tmp_data(ll, &
+ cdd_pv), tmp_data(ll,cdd_w), &
+ (tmp_idata(ll,k),k=cid_i,cid_k), &
+ tmp_idata(ll,cid_pv), tmp_idata(ll,cid_obs)
+! re-read with sub-index (species)
+ IF (tmp_idata(ll,cid_pv)==pv_conc .AND. &
+ read_species) READ(line,*,err=1006,end=1006) &
+ tmp_data(ll,cdd_pv), tmp_data(ll,cdd_w), &
+ (tmp_idata(ll,k),k=cid_i,cid_k), &
+ tmp_idata(ll,cid_pv), tmp_idata(ll,cid_si), &
+ tmp_idata(ll,cid_obs)
+ ELSE IF (level_timer/=1 .AND. .NOT. read_obs) THEN
+ READ(line,*,err=1007,end=1007) tmp_data(ll, &
+ cdd_pv), tmp_data(ll,cdd_w), &
+ (tmp_idata(ll,k),k=cid_i,cid_k), &
+ tmp_idata(ll,cid_pv)
+! re-read with sub-index (species)
+ IF (tmp_idata(ll,cid_pv)==pv_conc .AND. &
+ read_species) READ(line,*,err=1008,end=1008) &
+ tmp_data(ll,cdd_pv), tmp_data(ll,cdd_w), &
+ (tmp_idata(ll,k),k=cid_i,cid_k), &
+ tmp_idata(ll,cid_pv), tmp_idata(ll,cid_si)
+ END IF
+! ----------
+ ELSE
+! ----------
+! absolute position
+ IF (level_timer==1 .AND. read_obs) THEN
+ READ(line,*,err=2001,end=2001) tmp_data(ll, &
+ cdd_pv), tmp_data(ll,cdd_w), &
+ tmp_data(ll,cdd_time), (tmp_data(ll,k),k=cdd_i, &
+ cdd_k), tmp_idata(ll,cid_pv), &
+ tmp_idata(ll,cid_obs)
+! re-read with sub-index (species)
+ IF (tmp_idata(ll,cid_pv)==pv_conc .AND. &
+ read_species) READ(line,*,err=2002,end=2002) &
+ tmp_data(ll,cdd_pv), tmp_data(ll,cdd_w), &
+ tmp_data(ll,cdd_time), (tmp_data(ll,k),k=cdd_i, &
+ cdd_k), tmp_idata(ll,cid_pv), &
+ tmp_idata(ll,cid_si), tmp_idata(ll,cid_obs)
+ ELSE IF (level_timer==1 .AND. .NOT. read_obs) THEN
+ READ(line,*,err=2003,end=2003) tmp_data(ll, &
+ cdd_pv), tmp_data(ll,cdd_w), &
+ tmp_data(ll,cdd_time), (tmp_data(ll,k),k=cdd_i, &
+ cdd_k), tmp_idata(ll,cid_pv)
+! re-read with sub-index (species)
+ IF (tmp_idata(ll,cid_pv)==pv_conc .AND. &
+ read_species) READ(line,*,err=2004,end=2004) &
+ tmp_data(ll,cdd_pv), tmp_data(ll,cdd_w), &
+ tmp_data(ll,cdd_time), (tmp_data(ll,k),k=cdd_i, &
+ cdd_k), tmp_idata(ll,cid_pv), &
+ tmp_idata(ll,cid_si)
+ ELSE IF (level_timer/=1 .AND. read_obs) THEN
+ READ(line,*,err=2005,end=2005) tmp_data(ll, &
+ cdd_pv), tmp_data(ll,cdd_w), &
+ (tmp_data(ll,k),k=cdd_i,cdd_k), &
+ tmp_idata(ll,cid_pv), tmp_idata(ll,cid_obs)
+! re-read with sub-index (species)
+ IF (tmp_idata(ll,cid_pv)==pv_conc .AND. &
+ read_species) READ(line,*,err=2006,end=2006) &
+ tmp_data(ll,cdd_pv), tmp_data(ll,cdd_w), &
+ (tmp_data(ll,k),k=cdd_i,cdd_k), &
+ tmp_idata(ll,cid_pv), tmp_idata(ll,cid_si), &
+ tmp_idata(ll,cid_obs)
+ ELSE IF (level_timer/=1 .AND. .NOT. read_obs) THEN
+ READ(line,*,err=2007,end=2007) tmp_data(ll, &
+ cdd_pv), tmp_data(ll,cdd_w), &
+ (tmp_data(ll,k),k=cdd_i,cdd_k), &
+ tmp_idata(ll,cid_pv)
+! re-read with sub-index (species)
+ IF (tmp_idata(ll,cid_pv)==pv_conc .AND. &
+ read_species) READ(line,*,err=2008,end=2008) &
+ tmp_data(ll,cdd_pv), tmp_data(ll,cdd_w), &
+ (tmp_data(ll,k),k=cdd_i,cdd_k), &
+ tmp_idata(ll,cid_pv), tmp_idata(ll,cid_si)
+ END IF
+ END IF
+! ----------
+
+ IF (read_absolute) THEN
+! search index values for x,y,z
+ tmp_idata(ll,cid_i) = 0
+ DO k = 1, i0
+ IF (delxa(k)-0.5D0*delx(k)<=tmp_data(ll,cdd_i)) &
+ tmp_idata(ll,cid_i) = k
+ END DO
+ tmp_idata(ll,cid_j) = 0
+ DO k = 1, j0
+ IF (delya(k)-0.5D0*dely(k)<=tmp_data(ll,cdd_j)) &
+ tmp_idata(ll,cid_j) = k
+ END DO
+ tmp_idata(ll,cid_k) = 0
+ DO k = 1, k0
+ IF (delza(k)-0.5D0*delz(k)<=tmp_data(ll,cdd_k)) &
+ tmp_idata(ll,cid_k) = k
+ END DO
+ ELSE
+! convert index i,j,k into absolute postion
+ tmp_data(ll,cdd_i) = delxa(tmp_idata(ll,cid_i))
+ tmp_data(ll,cdd_j) = delya(tmp_idata(ll,cid_j))
+ tmp_data(ll,cdd_k) = delza(tmp_idata(ll,cid_k))
+ END IF
+
+! modify with 'tunit'
+ tmp_data(ll,cdd_time) = tmp_data(ll,cdd_time)*tunit
+! sanity checks
+ IF (tmp_data(ll,cdd_time)<simtime_0 .OR. &
+ tmp_data(ll,cdd_time)>max_simtime) THEN
+ WRITE(*,'(1A,1I6,1A)') &
+ 'error: timer value out of range, at line ', j, '!'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+ END IF
+ IF (tmp_data(ll,cdd_w)<dabs(1.0d-10*tmp_data(ll,cdd_pv))) THEN
+ tmp_data(ll,cdd_w)=max(dabs(1.0d-10*tmp_data(ll,cdd_pv)),1.0d-99)
+ WRITE(*,'(1A,1I6,1A,1G12.4,1A)') &
+ 'warning: given error seems to be to small, at line ', j, &
+ ', cutting them to ',tmp_data(ll,cdd_w),'!'
+ END IF
+ IF (tmp_idata(ll,cid_i)<1 .OR. &
+ tmp_idata(ll,cid_i)>i0 .OR. &
+ tmp_idata(ll,cid_j)<1 .OR. &
+ tmp_idata(ll,cid_j)>j0 .OR. &
+ tmp_idata(ll,cid_k)<1 .OR. tmp_idata(ll,cid_k)>k0) &
+ THEN
+ WRITE(*,'(1A,1I6,1A)') &
+ 'error: index out of range, at line ', j, '!'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+ END IF
+ IF (tmp_data(ll,cdd_i)<0.0D0 .OR. &
+ tmp_data(ll,cdd_i)>delxa(i0)+0.5D0*delx(i0) .OR. &
+ tmp_data(ll,cdd_j)<0.0D0 .OR. &
+ tmp_data(ll,cdd_j)>delya(j0)+0.5D0*dely(j0) .OR. &
+ tmp_data(ll,cdd_k)<0.0D0 .OR. &
+ tmp_data(ll,cdd_k)>delza(k0)+0.5D0*delz(k0)) THEN
+ WRITE(*,'(1A,1I6,1A)') &
+ 'error: absolute position out of range, at line ', &
+ j, '!'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+ END IF
+ IF (tmp_idata(ll,cid_pv)<1 .OR. &
+ tmp_idata(ll,cid_pv)>npv) THEN
+ WRITE(*,'(1A,1I1,1A,1I6,1A)') &
+ 'error: physical value index out of range [1..', &
+ npv, '], at line ', j, '!'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+ END IF
+ IF (tmp_idata(ll,cid_si)<0 .OR. &
+ tmp_idata(ll,cid_si)>ntrans) THEN
+ WRITE(*,'(1A,1I6,1A)') &
+ 'error: species index out of range, at line ', j, &
+ '!'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+ END IF
+ END DO
+ END IF
+ END IF
+ END DO
+! sanity check
+ IF (ll/=ndata) THEN
+ WRITE(*,'(1A)') 'error: lost some data in "read_data.f" !'
+ WRITE(*,*) ' searching:', ndata, ', but reading:', ll
+ STOP
+ END IF
+
+ IF (ndata>=1) THEN
+! compare data and boundaries, eleminate one of them when on the same position
+ k = 0
+ DO j = 1, ndata
+ DO i = 1, nbc_data
+! only dirichlet boundaries
+ IF ((tmp_idata(j,cid_i)==ibc_data(i, &
+ cbc_i)) .AND. (tmp_idata(j,cid_j)==ibc_data(i, &
+ cbc_j)) .AND. (tmp_idata(j,cid_k)==ibc_data(i, &
+ cbc_k)) .AND. (bt_diri==ibc_data(i, &
+ cbc_bt)) .AND. (tmp_idata(j,cid_pv)==ibc_data(i, &
+ cbc_pv))) THEN
+! disable them, later delete/ignore
+#ifndef DbB
+! BbD, Boundaries before Data
+ tmp_idata(j,cid_pv) = 0
+#else
+! DbB, Data before Boundaries
+ ibc_data(i,cbc_pv) = -ibc_data(i,cbc_pv)
+#endif
+ k = k + 1
+ ELSE
+! dont change, leave them
+ END IF
+ END DO
+ END DO
+
+ ll = 0
+! compare data with data, eleminate one of them when on the same position
+ DO j = 1, ndata
+ DO i = 1, ndata
+! only dirichlet boundaries
+ IF ((tmp_idata(i,cid_i)==tmp_idata(j, &
+ cid_i)) .AND. (tmp_idata(i,cid_j)==tmp_idata(j, &
+ cid_j)) .AND. (tmp_idata(i,cid_k)==tmp_idata(j, &
+ cid_k)) .AND. (tmp_idata(i,cid_pv)==tmp_idata(j, &
+ cid_pv)) .AND. (tmp_idata(i,cid_si)==tmp_idata(j, &
+ cid_si)) .AND. (tmp_data(i,cdd_time)==tmp_data(j, &
+ cdd_time)) .AND. (i/=j) .AND. &
+ tmp_idata(j,cid_pv)/=0) THEN
+! disable them, later delete/ignore
+ tmp_idata(j,cid_pv) = 0
+ ll = ll + 1
+! skip this i-loop
+ GO TO 30
+ END IF
+ END DO
+30 CONTINUE
+ END DO
+
+#ifdef DbB
+ IF (k>0) WRITE(*,'(A,I6,2A)') 'warning: ', k, ' &
+ &boundary points have been deleted, because of &
+ &conflicting data'
+! rearange full boundary arrays
+! j - "copy from" index
+! i - "copy to" index
+ j = 1
+ DO i = 1, nbc_data - k
+100 IF (j<=nbc_data) THEN
+ IF (ibc_data(j,cbc_pv)<0) THEN
+! delete boundary property "j"
+! and increase "j" to the next "to be copy" position
+ j = j + 1
+ GO TO 100
+ ELSE
+! fill entry for boundary point "i", copy "j" to "i" (now dense)
+ DO i2 = 1, nibc
+ ibc_data(i,i2) = ibc_data(j,i2)
+ END DO
+ DO i2 = 1, ndbc
+ dbc_data(i,i2,ismpl) = dbc_data(j,i2,ismpl)
+ END DO
+ j = j + 1
+ END IF
+ END IF
+ END DO
+ nbc_data = nbc_data - k
+ k = 0
+! reinit first/last_<pv>
+ CALL sort_bc(ismpl)
+#endif
+ IF (k>0) WRITE(*,'(A,I6,2A)') 'warning: ', k, ' &
+ &data have been deleted, because of conflicting &
+ &boundaries'
+ IF (ll>0) WRITE(*,'(A,I6,2A)') 'warning: ', ll, &
+ ' data have been deleted, because of conflicting data'
+ ll = ll + k
+ ndata = ndata - ll
+
+ CALL alloc_data(ismpl)
+
+ j = 0
+! *** copy ordered !!! ***
+ DO l = 1, npv
+! l=1: copy-in HEAD elements
+! 2: copy-in TEMP elements
+! 3: copy-in CONC elements
+! 5: copy-in PRES elements
+! 6: copy-in BHPR elements
+ DO i = 1, ndata + ll
+ IF (tmp_idata(i,cid_pv)==l) THEN
+ j = j + 1
+ DO i2 = 1, n_ddata
+ ddata(j,i2) = tmp_data(i,i2)
+ END DO
+ DO i2 = 1, n_idata
+ idata(j,i2) = tmp_idata(i,i2)
+ END DO
+ END IF
+ END DO
+ END DO
+! sanity check
+ IF (j/=ndata) THEN
+ WRITE(*,'(1A,1I5,1A,1I5,1A)') 'error: lost some DATA,', &
+ j, '/', ndata, ', in "read_data"!!!'
+ STOP
+ END IF
+
+! need "ndata_p/t/c/e" before "alloc_inverse"
+ ndata_h = 0
+ ndata_t = 0
+ ndata_c = 0
+ ndata_p = 0
+ ndata_s = 0
+ ndata_b = 0
+ DO l = 1, ndata
+ i = idata(l,cid_i)
+ j = idata(l,cid_j)
+ k = idata(l,cid_k)
+ type = idata(l,cid_pv)
+ ozone = idata(l,cid_obs)
+ IF (type==pv_head) ndata_h = ndata_h + 1
+ IF (type==pv_pres) ndata_p = ndata_p + 1
+ IF (type==pv_temp) ndata_t = ndata_t + 1
+ IF (type==pv_conc) ndata_c = ndata_c + 1
+ IF (type==pv_bhpr) ndata_b = ndata_b + 1
+ END DO
+! sanity check
+ IF (ndata_h+ndata_t+ndata_c+ndata_p+ndata_s+ndata_b/=ndata) THEN
+ WRITE(*,'(1A,1I5,1A,1I5,1A)') 'error: lost some DATA,', &
+ ndata_h + ndata_t + ndata_c + ndata_p + ndata_s + ndata_b, '/', &
+ ndata, ', in "read_data"(2)!!!'
+ STOP
+ END IF
+ WRITE(*,'(1A,1I7)') &
+ ' [I] : data and data node adresses, records=', ndata
+ ELSE
+ WRITE(*,*) ' <D> : no observed data found, records=0'
+ END IF
+
+ DEALLOCATE(tmp_idata)
+ DEALLOCATE(tmp_data)
+
+! finish HDF5 support, when available
+ CALL close_hdf5()
+ CLOSE(79)
+
+ RETURN
+
+! error handler
+901 WRITE(*,'(2A)') 'error: expecting "read" or a timer value', &
+ ' behind the keyword "timer=" !!!'
+ STOP
+1001 WRITE(*,'(2A,1I6,1A)') &
+ 'error: expecting [value error timer i j k value-type obs', &
+ '] at line ', j, ' !!!'
+ WRITE(*,'(1A)') &
+ ' cell position index: i,j,k are integer values'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+1002 WRITE(*,'(2A,1I6,1A)') 'error: expecting [value error &
+ &timer i j k value-type species', ' obs] at line ', j, &
+ ' !!!'
+ WRITE(*,'(1A)') &
+ ' cell position index: i,j,k are integer values'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+1003 WRITE(*,'(2A,1I6,1A)') &
+ 'error: expecting [value error timer i j k value-type', &
+ '] at line ', j, ' !!!'
+ WRITE(*,'(1A)') &
+ ' cell position index: i,j,k are integer values'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+1004 WRITE(*,'(2A,1I6,1A)') 'error: expecting [value error &
+ &timer i j k value-type species', '] at line ', j, ' !!!'
+ WRITE(*,'(1A)') &
+ ' cell position index: i,j,k are integer values'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+1005 WRITE(*,'(2A,1I6,1A)') &
+ 'error: expecting [value error i j k value-type obs', &
+ '] at line ', j, ' !!!'
+ WRITE(*,'(1A)') &
+ ' cell position index: i,j,k are integer values'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+1006 WRITE(*,'(2A,1I6,1A)') &
+ 'error: expecting [value error i j k value-type species obs', &
+ '] at line ', j, ' !!!'
+ WRITE(*,'(1A)') &
+ ' cell position index: i,j,k are integer values'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+1007 WRITE(*,'(2A,1I6,1A)') &
+ 'error: expecting [value error i j k value-type', &
+ '] at line ', j, ' !!!'
+ WRITE(*,'(1A)') &
+ ' cell position index: i,j,k are integer values'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+1008 WRITE(*,'(2A,1I6,1A)') &
+ 'error: expecting [value error i j k value-type species', &
+ '] at line ', j, ' !!!'
+ WRITE(*,'(1A)') &
+ ' cell position index: i,j,k are integer values'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+2001 WRITE(*,'(2A,1I6,1A)') &
+ 'error: expecting [value error timer x y z value-type obs', &
+ '] at line ', j, ' !!!'
+ WRITE(*,'(1A)') &
+ ' absolute cell position: x,y,z are floating point values'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+2002 WRITE(*,'(2A,1I6,1A)') 'error: expecting [value error &
+ &timer x y z value-type species', ' obs] at line ', j, &
+ ' !!!'
+ WRITE(*,'(1A)') &
+ ' absolute cell position: x,y,z are floating point values'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+2003 WRITE(*,'(2A,1I6,1A)') &
+ 'error: expecting [value error timer x y z value-type', &
+ '] at line ', j, ' !!!'
+ WRITE(*,'(1A)') &
+ ' absolute cell position: x,y,z are floating point values'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+2004 WRITE(*,'(2A,1I6,1A)') 'error: expecting [value error &
+ &timer x y z value-type species', '] at line ', j, ' !!!'
+ WRITE(*,'(1A)') &
+ ' absolute cell position: x,y,z are floating point values'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+2005 WRITE(*,'(2A,1I6,1A)') &
+ 'error: expecting [value error x y z value-type obs', &
+ '] at line ', j, ' !!!'
+ WRITE(*,'(1A)') &
+ ' absolute cell position: x,y,z are floating point values'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+2006 WRITE(*,'(2A,1I6,1A)') &
+ 'error: expecting [value error x y z value-type species obs', &
+ '] at line ', j, ' !!!'
+ WRITE(*,'(1A)') &
+ ' absolute cell position: x,y,z are floating point values'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+2007 WRITE(*,'(2A,1I6,1A)') &
+ 'error: expecting [value error x y z value-type', &
+ '] at line ', j, ' !!!'
+ WRITE(*,'(1A)') &
+ ' absolute cell position: x,y,z are floating point values'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+2008 WRITE(*,'(2A,1I6,1A)') &
+ 'error: expecting [value error x y z value-type species', &
+ '] at line ', j, ' !!!'
+ WRITE(*,'(1A)') &
+ ' absolute cell position: x,y,z are floating point values'
+ WRITE(*,'(3A)') ' given:"', line, '"'
+ STOP
+ END
diff --git a/forward/input/read_model.f90 b/forward/input/read_model.f90
new file mode 100644
index 0000000..71b0639
--- /dev/null
+++ b/forward/input/read_model.f90
@@ -0,0 +1,2028 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief read model parameter
+!> @param[in] filename model file name
+!> @param[in] ismpl local sample index
+!> @details
+!> Note: To be able to use input file parsing with hdf5, the
+!> hdf5-input-files have to be generated using the script:
+!> `convert_to_hdf5.py`. This script can be found in the repository
+!> `SHEMAT-Suite_Scripts` under
+!> `python/preprocessing/convert_to_hdf5.py`.
+ SUBROUTINE read_model(filename,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_flow
+ use mod_temp
+ use mod_conc
+ use mod_time
+ use mod_data
+ use mod_blocking_size
+ use mod_OMP_TOOLS
+ use mod_linfos
+#ifndef noHDF
+ use mod_input_file_parser_hdf5
+#endif
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k, l
+
+ INCLUDE 'OMP_TOOLS.inc'
+!
+ character (len=80) :: filename
+ character (len=80) :: line
+ character (len=320) :: longline
+ character (len=4) :: ctmp
+ character (len=32) :: strng
+ character (len=1) :: sbc
+!
+ DOUBLE PRECISION dtmp
+ DOUBLE PRECISION, ALLOCATABLE :: datmp(:,:)
+ LOGICAL, ALLOCATABLE :: ltmp(:,:)
+! is head needed - head based computation
+ LOGICAL head_needed
+!
+ INTEGER tmplen, minunits, posi, ilost
+!
+ INTEGER ijk, omp_inner, omp_outer
+ INTEGER i1, i2, nbc_sections
+ INTEGER tracer
+ INTEGER sm_max
+!
+ INTEGER locstr, lblank, read_direction, get_ioptval
+ EXTERNAL locstr, lblank, read_direction, get_ioptval
+ LOGICAL found, no_ext_link, no_ext_link_int, test_null, &
+ test_option
+ EXTERNAL found, no_ext_link, no_ext_link_int, test_null, &
+ test_option
+ logical :: found_marker
+ character(len=80) :: full_bc_name
+
+ found_marker = .false.
+
+!
+ CALL read_check(filename)
+!
+ WRITE(*,*) ' '
+ WRITE(*,*) ' reading model input parameter:'
+ WRITE(*,*) ' from file "', filename(:lblank(filename)),'"'
+ WRITE(*,*) ' '
+
+! ------------------
+! default sample index
+ ismpl = 1
+ nsmpl = 1
+! generic init staff equal for all models
+ CALL model_init(ismpl)
+! setup string constants for the number of property-units and bc-units
+ WRITE(c_npropunit,'(I2)') lastidx -firstidx +1
+ WRITE(c_nbcunit,'(I2)') bc_lastidx -bc_firstidx +1
+! setup string constant for the number of variables
+ WRITE(c_npv,'(I2)') npv
+! ------------------
+! read file
+ OPEN(79,file=filename,status='old')
+
+! init HDF5 support, when available
+ CALL open_hdf5(' ')
+
+ title = 'NO TITLE'
+ IF (found(79,key_char//' title',line,.FALSE.)) THEN
+ READ(79,'(1A)',err=200,end=200) title
+ WRITE(*,*) ' [R] : title'
+ ELSE
+ WRITE(*,*) ' <D> : no title '
+ END IF
+
+ runmode = 0
+ IF (found(79,key_char//' runmode',line,.FALSE.)) THEN
+ READ(79,*,err=202,end=202) runmode
+ WRITE(*,*) ' [R] : runmode'
+ IF (runmode==0) WRITE(*,*) ' >>> forward modeling'
+ IF (runmode==1) WRITE(*,*) &
+ ' >>> forward modeling and data fit'
+ IF (runmode==2) WRITE(*,*) &
+ ' >>> inverse modeling (extra steady state)'
+ IF (runmode==3) WRITE(*,*) ' >>> inverse modeling '
+ ELSE
+ WRITE(*,*) ' <D> : runmode=0, forward modeling !'
+ END IF
+
+#ifdef DEBUG
+ n_debugout = 0
+ CALL read_debugout(ismpl)
+#endif
+
+ write_smonitor = .FALSE.
+ transient = .FALSE.
+
+ ! Default time unit [s]
+ tunit = tunit_const
+
+ linfos(1) = 2
+ linfos(2) = 1
+ linfos(3:4) = 0
+ IF (found(79,key_char//' linfo',line,.FALSE.)) THEN
+ READ(79,*) linfos
+ WRITE(*,*) ' [R] : linfo'
+ END IF
+
+#ifdef BENCH
+ IF (found(79,key_char//' ilu block size',line,.FALSE.)) THEN
+ READ(79,*) block_i,block_j,block_k
+ linfos(4) = -1000
+ WRITE(*,*) ' [R] : ILU block size (benchmark mode)'
+ END IF
+#endif
+
+! (pseudo) realisation number
+ sm_max = 1
+ IF (found(79,key_char//' samples',line,.FALSE.)) THEN
+ READ(79,*,err=201,end=201) nsmpl
+ WRITE(*,'(1A,1I6)') ' [R] : samples =',nsmpl
+ END IF
+ sm_max = nsmpl
+
+ IF (found(79,key_char//' PROPS',line,.FALSE.)) THEN
+ CALL get_arg('PROPS',line,i,j)
+ IF (i<1 .OR. j<i) THEN
+ READ(79,*,err=206,end=206) def_props
+ ELSE
+ READ(line(i:j),*) def_props
+ END IF
+ ELSE
+ WRITE(*,'(2A)') &
+ 'error: can not find section "'//key_char//' PROPS=<...>",', &
+ ' must be defined!'
+ def_props = '<name>'
+ END IF
+ CALL props_check(ismpl)
+
+ IF (found(79,key_char//' USER',line,.FALSE.)) THEN
+ CALL get_arg('USER',line,i,j)
+ IF (i<1 .OR. j<i) THEN
+ READ(79,*,err=207,end=207) def_user
+ ELSE
+ READ(line(i:j),*) def_user
+ END IF
+ ELSE
+ WRITE(*,'(2A)') &
+ 'error: can not find section "'//key_char//' USER=<...>",', &
+ ' must be defined!'
+ def_user = '<name>'
+ END IF
+ CALL user_check(ismpl)
+
+! test for command line option given OpenMP parallelisation
+ omp_outer = 0
+ omp_inner = 0
+ IF (test_option('-tsample')) THEN
+ omp_outer = get_ioptval('-tsample')
+ END IF
+ IF (test_option('-tsolve')) THEN
+ omp_inner = get_ioptval('-tsolve')
+ END IF
+ IF (omp_outer>0 .AND. omp_inner>0) WRITE(*,'(2(1A,1I3),1A)') &
+ ' [R] : command line OpenMP thread configuration (', &
+ max(omp_outer,1), 'x', max(omp_inner,1), ' threads)'
+ IF (omp_outer==0 .AND. omp_inner>0) WRITE(*,'(2A,1I3,1A)') &
+ ' [R] : command line OpenMP thread configuration (', &
+ ' ?x', max(omp_inner,1), ' threads)'
+ IF (omp_outer>0 .AND. omp_inner==0) WRITE(*,'(1A,1I3,1A)') &
+ ' [R] : command line OpenMP thread configuration (', &
+ max(omp_outer,1), 'x ? threads)'
+
+! test for default environment given OpenMP parallelisation
+ IF (omp_inner>0) THEN
+!$OMP parallel default(none) shared(Tlevel_0, omp_inner)&
+!$OMP num_threads(omp_inner)
+!$OMP master
+! test thread configuartion for thread-level 0
+! (max number of sample threads)
+ tlevel_0 = omp_get_num_of_threads()
+!$OMP end master
+!$OMP end parallel
+ ELSE
+!$OMP parallel default(none) shared(Tlevel_0)
+!$OMP master
+! get the number threads for thread-level 0
+! (max number of sample threads)
+ tlevel_0 = omp_get_num_of_threads()
+!$OMP end master
+!$OMP end parallel
+ END IF
+!$OMP parallel default(none) num_threads(Tlevel_0)&
+!$OMP shared(Tlevel_0,Tlevel_1,omp_inner)
+ IF (omp_get_his_thread_num()==0) THEN
+ tlevel_1 = tlevel_0
+ tlevel_0 = 1
+ END IF
+!$OMP end parallel
+
+! use "sm_max" instead of "nsmpl", because of the ENKF case nsmpl = sm_max+1
+ IF (omp_outer>1) WRITE(*,'(2A)') &
+ ' [I] : OpenMP parallelisation limited, ', &
+ 'target build not support nesting !'
+#ifdef PROPS_IAPWS
+ WRITE(*,'(2A)') ' [I] : OpenMP parallelisation limited, ', &
+ 'IAPWS target specific behaviour.'
+#endif
+ IF (tlevel_0>1 .OR. tlevel_1>1) WRITE(*,'(1A,1I3,1A,1I3,1A)') &
+ ' [I] : OpenMP parallelisation enabled (', tlevel_0, 'x', &
+ tlevel_1, ' threads)'
+
+ IF (test_option('-scalemp')) THEN
+ CALL init_scalemp_binding()
+ ELSE IF (test_option('-libnuma')) THEN
+ CALL init_scalemp_binding()
+ ELSE IF (test_option('-tbind')) THEN
+ CALL get_coptval('-tbind',line)
+ CALL load_binding(line)
+ ELSE
+ CALL load_binding('default')
+ END IF
+
+#ifndef noHDF
+ if (h5parse_use_hdf5_datafile) then
+ i0 = h5parse_read_dimension_size_for_dataset("grid/delx")
+ j0 = h5parse_read_dimension_size_for_dataset("grid/dely")
+ k0 = h5parse_read_dimension_size_for_dataset("grid/delz")
+ found_marker = .true.
+ else
+#endif
+ IF (found(79,key_char//' grid',line,.FALSE.)) THEN
+ READ(79,*,err=203,end=203) i0, j0, k0
+ found_marker = .true.
+ ELSE
+ WRITE(*,'(1A)') &
+ 'error: no grid dimensions i0, j0, k0 defined !'
+ STOP
+ END IF
+#ifndef noHDF
+ endif
+#endif
+ if (found_marker) then
+ found_marker = .false.
+ write(*,'(A,3(I4,A))') ' [R] : [i0, j0, k0] = [', i0, ',', &
+ j0, ',', k0, ']'
+ end if
+
+
+ maxiter_nl = 100
+ nladapt = 0
+ nlconverge = 0
+ IF (found(79,key_char//' nlsolve',line,.FALSE.)) THEN
+ READ(79,*,err=204,end=204) maxiter_nl, nladapt
+ READ(79,*,err=1432,end=1432) nlconverge
+ GOTO 1433
+1432 nlconverge=0
+1433 WRITE(*,*) ' [R] : nonlinear solver parameter'
+ if (.NOT. nlconverge .eq. 0) write(*,*) ' [W] : Nonlinear Convergence test disabled!'
+ IF (nladapt==0) THEN
+ WRITE(*,*) ' [I] : fixed relxation factor assumed'
+ ELSE IF (nladapt==1) THEN
+ WRITE(*,*) ' [I] : adaptive relaxation type ', nladapt
+ WRITE(*,*) &
+ ' [E] : adaptive relaxation disabled manually!', ' &
+ &-> please select the fixed mode (set 0) or &
+ &remove this STOP!'
+! Please ask Volker Rath or Andreas Wolf !!!
+ STOP
+ ELSE
+ WRITE(*,*) 'error: relaxation type ', nladapt, &
+ ' not defined'
+ STOP
+ END IF
+ END IF
+
+! --- read switches ---
+ IF (found(79,key_char//' active',line,.FALSE.)) THEN
+ head_active = .FALSE.
+ pres_active = .FALSE.
+ temp_active = .FALSE.
+ trac_active = .FALSE.
+ chem_active = .FALSE.
+ trans_active = .FALSE.
+! test for each allowed type of calculation
+ i = locstr(line,'head')
+ IF (i>=1) THEN
+ head_active = .TRUE.
+ pres_active = .TRUE.
+ END IF
+ i = locstr(line,'pres')
+ IF (i>=1) THEN
+ pres_active = .TRUE.
+#ifdef head_base
+ head_active = .TRUE.
+#endif
+ END IF
+ i = locstr(line,'temp')
+ IF (i>=1) THEN
+ temp_active = .TRUE.
+ END IF
+ i = locstr(line,'trac')
+ IF (i>=1) THEN
+ trac_active = .TRUE.
+ END IF
+ i = locstr(line,'chem')
+ IF (i>=1) THEN
+ chem_active = .TRUE.
+ END IF
+ IF (trac_active .OR. chem_active) trans_active = .TRUE.
+ ELSE
+ head_active = .TRUE.
+ pres_active = .TRUE.
+ temp_active = .TRUE.
+ trac_active = .FALSE.
+ chem_active = .FALSE.
+ trans_active = .FALSE.
+ END IF
+
+! default file output compression: plain, compress_out=1
+! default file output compression: bzip2 -> "*.bz2", compress_out=2
+ compress_out = 1
+ IF (found(79,key_char//' file output',line,.FALSE.)) THEN
+ hdf_out = .FALSE.
+ tec_out = .FALSE.
+ vtk_out = .FALSE.
+ txt_out = .FALSE.
+ ctmp = ' '
+
+! test for each allowed type of output files
+ i = locstr(line,'h5')
+ IF (i>=1) THEN
+ hdf_out = .TRUE.
+ ctmp(1:1) = 'X'
+ END IF
+!-
+ i = locstr(line,'plt')
+ IF (i>=1) THEN
+ tec_out = .TRUE.
+ ctmp(2:2) = 'X'
+ END IF
+!-
+ i = locstr(line,'vtk')
+ IF (i>=1) THEN
+ vtk_out = .TRUE.
+ ctmp(3:3) = 'X'
+ END IF
+!-
+ i = locstr(line,'txt')
+ IF (i>=1) THEN
+ txt_out = .TRUE.
+ ctmp(4:4) = 'X'
+ END IF
+!- may be obsolete later, use "h5" instead
+ i = locstr(line,'hdf')
+ IF (i>=1) THEN
+ hdf_out = .TRUE.
+ ctmp(1:1) = 'X'
+ END IF
+!- may be obsolete later, use "plt" instead
+ i = locstr(line,'tec')
+ IF (i>=1) THEN
+ tec_out = .TRUE.
+ ctmp(2:2) = 'X'
+ END IF
+!-
+ WRITE(*,'(1A,4(1A,1A1),1A)') ' [R] : output suffix: ', &
+ '.h5:[', ctmp(1:1), '], .plt:[', ctmp(2:2), '], .vtk:[', &
+ ctmp(3:3), '], .txt:[', ctmp(4:4), ']'
+
+ DO j = 1, ncompress
+! looking for suffix names -> enable compression tool
+ i = locstr(line,compress_suffix(j))
+ IF (i>=1) THEN
+ compress_out = j
+ END IF
+ END DO
+ IF (compress_out>1) WRITE(*,'(3A)') &
+ ' [R] : output file compression enabled [*.', &
+ compress_suffix(compress_out), ']'
+ ELSE
+ hdf_out = .TRUE.
+ tec_out = .FALSE.
+ vtk_out = .FALSE.
+ txt_out = .FALSE.
+ END IF
+
+ DO i = 1, nprop
+ out_prop(i) = .TRUE.
+ END DO
+ DO i = 1, npv
+ out_pv(i) = .TRUE.
+ END DO
+ DO i = 1, nout_ijk
+ out_ijk(i) = .TRUE.
+ END DO
+! disable specific hdf5-outputs
+ IF (found(79,key_char//' disable output',line,.FALSE.)) THEN
+ READ(79,'(1A)',end=215) longline
+ CALL read_oprop(longline)
+ CALL read_opv(longline)
+ CALL read_oijk(longline)
+ END IF
+
+ write_param = .TRUE.
+ IF (found(79,key_char//' disable small output',line,.FALSE.)) THEN
+! disable the additional parameter output file
+ write_param = .FALSE.
+ END IF
+
+ write_disable = .FALSE.
+ IF (found(79,key_char//' set write disable',line,.FALSE.)) THEN
+ write_disable = .TRUE.
+ write(*,'(1A)') &
+ ' [R] : Set write disable, write_disable = .TRUE.'
+ END IF
+
+ write_iter_disable = .FALSE.
+ IF (found(79,key_char//' set write iter disable',line,.FALSE.)) THEN
+ write_iter_disable = .TRUE.
+ write(*,'(1A)') &
+ ' [R] : Set write iter disable, write_iter_disable = .TRUE.'
+ END IF
+
+ read_external_input = .TRUE.
+ IF (found(79,key_char//' read external input',line,.FALSE.)) THEN
+ read(unit = 79, fmt = '(l1)') read_external_input
+ write(unit = *, fmt = *) ' [R] : read_external_input = ', read_external_input
+ END IF
+
+! count the number of bc-entries (sections and entries)
+ nbc_sections = 0
+ nbc_data = 0
+#ifndef noHDF
+ if (h5parse_use_hdf5_datafile) then
+ do i = 1, size(pv_name)
+ do k = 1, size(bc_name)
+ j=1
+ write(full_bc_name, '(A,"_",A,"_",I0)') pv_name(i), bc_name(k), j
+ do while (h5parse_check_dataset_exist("bc/"//full_bc_name))
+ nbc_sections = nbc_sections + 1
+ nbc_data = nbc_data + h5parse_read_dimension_size_for_dataset("bc/"//full_bc_name)
+ j = j+1
+ write(full_bc_name, '(A,"_",A,"_",I0)') pv_name(i), bc_name(k), j
+ end do
+ end do
+ end do
+ else
+#endif
+ REWIND 79
+10 READ(79,'(1A)',end=11) line
+ i = 0
+ IF (head_active) i = i + locstr(line,key_char//' head bcd')
+ IF (head_active) i = i + locstr(line,key_char//' head bcn')
+ IF (head_active) i = i + locstr(line,key_char//' head bcw')
+ IF (pres_active) i = i + locstr(line,key_char//' pres bcd')
+ IF (pres_active) i = i + locstr(line,key_char//' pres bcn')
+ IF (pres_active) i = i + locstr(line,key_char//' pres bcw')
+ IF (temp_active) i = i + locstr(line,key_char//' temp bcd')
+ IF (temp_active) i = i + locstr(line,key_char//' temp bcn')
+ IF (trans_active) i = i + locstr(line,key_char//' conc bcd')
+ IF (trans_active) i = i + locstr(line,key_char//' conc bcn')
+! bc line?
+ IF (i==1) THEN
+! increase number of sections (reading later)
+ nbc_sections = nbc_sections + 1
+ CALL get_arg('simple',line,i,j)
+ IF (i>=1 .AND. j>=i) THEN
+ k = read_direction(line(i:j))
+ tmplen = 0
+ IF (k==1 .OR. k==2) tmplen = j0*k0
+ IF (k==3 .OR. k==4) tmplen = i0*k0
+ IF (k==5 .OR. k==6) tmplen = i0*j0
+ ELSE
+ CALL get_arg('records',line,i,j)
+ IF (i<1 .OR. j<i) THEN
+ READ(79,*,err=205,end=205) tmplen
+ ELSE
+ READ(line(i:j),*) tmplen
+ END IF
+ END IF
+! increase number of entries
+ nbc_data = nbc_data + tmplen
+!debug if (linfos(1).ge.2) write(*,'(1A,1I6)')
+!debug & ' [I] : BC block found, but reading later, size=',tmplen
+ END IF
+! read next line, up to the end of file
+ GO TO 10
+! restart file, because of the end of file here
+#ifndef noHDF
+ end if
+#endif
+11 REWIND 79
+! --- end switches ---
+
+ IF (head_active .OR. pres_active) THEN
+! control environment for head/pres based computation
+ WRITE(*,*) ' '
+ WRITE(*,*) ' reading flow parameters'
+ WRITE(*,*) ' '
+
+ aparf = 1.0D0
+ IF (found(79,key_char//' lsolvef',line,.FALSE.)) THEN
+ READ(79,'(A)') line
+ CALL read_solvpar(line,errf,controlf,lmaxitf,ismpl)
+ WRITE(*,'(1A,1I4,1A)') &
+ ' [R] : flow linear solver (control=', controlf, ')'
+ ELSE
+ IF (found(79,key_char//' error lsolvef',line,.TRUE.)) THEN
+ READ(79,*,err=210,end=210) errf
+ WRITE(*,*) ' [R] : error for flow linear solver'
+ END IF
+ IF (found(79,key_char//' maxiter lsolvef',line,.TRUE.)) THEN
+ READ(79,*,err=211,end=211) lmaxitf
+ WRITE(*,*) ' [R] : max-iter for flow linear solver'
+ END IF
+ IF (found(79,key_char//' name lsolvef',line,.TRUE.)) THEN
+ READ(79,'(A)') line
+ CALL read_solver(line,i,ismpl)
+ IF (i==-1) READ(line,*,err=212,end=212) i
+ WRITE(*,*) ' [R] : solver name for flow linear solver'
+ END IF
+ IF (found(79,key_char//' criteria lsolvef',line,.TRUE.)) THEN
+ READ(79,'(A)') line
+ CALL read_criteria(line,j,ismpl)
+ IF (j==-1) READ(line,*,err=213,end=213) j
+ WRITE(*,*) ' [R] : criteria for flow linear solver'
+ END IF
+ IF (found(79,key_char//' precondition lsolvef',line,.TRUE.)) THEN
+ READ(79,'(A)') line
+ CALL read_preco(line,k,ismpl)
+ IF (k==-1) READ(line,*,err=214,end=214) k
+ WRITE(*,*) ' [R] : precondition for flow linear solver'
+ END IF
+ CALL encntrl3(controlf,i,j,k)
+ END IF
+
+ IF (found(79,key_char//' nliterf',line,.TRUE.)) THEN
+ dtmp = -1.0D0
+ READ(79,*,err=101,end=101) nltolf, dtmp
+101 WRITE(*,*) ' [R] : flow nonlinear iteration tolerance'
+ IF (dtmp<0.0D0) THEN
+ WRITE(*,'(1A)') 'error: not reading relaxation factor!'
+ STOP
+ END IF
+ IF (nladapt==1) THEN
+ nlmaxf = dtmp
+ WRITE(*,*) ' [I] : max flow change/iteration'
+ ELSE
+ nlrelaxf = dtmp
+ WRITE(*,*) ' [I] : flow nonlinear relaxation factor'
+ END IF
+ END IF
+ ELSE
+ nltolf = 1.D-30
+ nltols = 1.D-30
+ WRITE(*,*) ' '
+ WRITE(*,*) ' <D> : no flow [disabled]'
+ WRITE(*,*) ' '
+ END IF
+
+ IF (temp_active) THEN
+ WRITE(*,*) ' '
+ WRITE(*,*) ' reading heat transport parameters'
+ WRITE(*,*) ' '
+ apart = 1.0D0
+ IF (found(79,key_char//' lsolvet',line,.FALSE.)) THEN
+ READ(79,'(A)') line
+ CALL read_solvpar(line,errt,controlt,lmaxitt,ismpl)
+ WRITE(*,'(1A,1I4,1A)') &
+ ' [R] : temperature linear solver (control=', controlt,')'
+ ELSE
+ IF (found(79,key_char//' error lsolvet',line,.TRUE.)) THEN
+ READ(79,*,err=220,end=220) errt
+ WRITE(*,*) ' [R] : error for temperature linear solver'
+ END IF
+ IF (found(79,key_char//' maxiter lsolvet',line,.TRUE.)) THEN
+ READ(79,*,err=221,end=221) lmaxitt
+ WRITE(*,*) &
+ ' [R] : max-iter for temperature linear solver'
+ END IF
+ IF (found(79,key_char//' name lsolvet',line,.TRUE.)) THEN
+ READ(79,'(A)') line
+ CALL read_solver(line,i,ismpl)
+ IF (i==-1) READ(line,*,err=222,end=222) i
+ WRITE(*,*) &
+ ' [R] : solver name for temperature linear solver'
+ END IF
+ IF (found(79,key_char//' criteria lsolvet',line,.TRUE.)) THEN
+ READ(79,'(A)') line
+ CALL read_criteria(line,j,ismpl)
+ IF (j==-1) READ(line,*,err=223,end=223) j
+ WRITE(*,*) &
+ ' [R] : criteria for temperature linear solver'
+ END IF
+ IF (found(79,key_char//' precondition lsolvet',line,.TRUE.)) THEN
+ READ(79,'(A)') line
+ CALL read_preco(line,k,ismpl)
+ IF (k==-1) READ(line,*,err=224,end=224) k
+ WRITE(*,*) &
+ ' [R] : precondition for temperature linear solver'
+ END IF
+ CALL encntrl3(controlt,i,j,k)
+ END IF
+
+ IF (found(79,key_char//' nlitert',line,.TRUE.)) THEN
+ dtmp = -1.0D0
+ READ(79,*,err=102,end=102) nltolt, dtmp
+102 WRITE(*,*) &
+ ' [R] : temperature nonlinear iteration tolerance'
+ IF (dtmp<0.0D0) THEN
+ WRITE(*,'(1A)') 'error: not reading relaxation factor!'
+ STOP
+ END IF
+ IF (nladapt==1) THEN
+ nlmaxt = dtmp
+ WRITE(*,*) ' [I] : max temperature change/iteration'
+ ELSE
+ nlrelaxt = dtmp
+ WRITE(*,*) &
+ ' [I] : temperature nonlinear relaxation factor'
+ END IF
+ END IF
+ ELSE
+ nltolt = 1.D-30
+ WRITE(*,*) ' '
+ WRITE(*,*) ' <D> : no temperature [disabled]'
+ WRITE(*,*) ' '
+ END IF
+
+ ntrac = 0
+ nchem = 0
+ ntrans = ntrac + nchem
+ IF (trans_active) THEN
+ WRITE(*,*) ' '
+ WRITE(*,*) ' reading chemical transport parameters'
+ WRITE(*,*) ' '
+
+ IF (found(79,key_char//' ntrans',line,.FALSE.)) THEN
+ READ(79,*,err=250,end=250) ntrac, nchem
+ ntrans = ntrac + nchem
+ WRITE(*,'(1A,2I4)') &
+ ' [R] : tracers, reactive components=', ntrac, nchem
+ ELSE
+ WRITE(*,*) ' <D> : no tracers or reactive components'
+ END IF
+ IF (ntrac<=0) trac_active = .FALSE.
+ IF (nchem<=0) chem_active = .FALSE.
+ trans_active = .FALSE.
+ IF (trac_active .OR. chem_active) trans_active = .TRUE.
+ END IF
+! [head/pres,temp, conc...]
+ conv_hmax = 3 + ntrans
+
+ IF (trans_active) THEN
+ aparc = 1.0D0
+ IF (found(79,key_char//' lsolvec',line,.FALSE.)) THEN
+ READ(79,'(A)') line
+ CALL read_solvpar(line,errc,controlc,lmaxitc,ismpl)
+ WRITE(*,'(1A,1I4,1A)') &
+ ' [R] : transport linear solver (control=', controlc, &
+ ')'
+ ELSE
+ IF (found(79,key_char//' error lsolvec',line,.TRUE.)) THEN
+ READ(79,*,err=230,end=230) errc
+ WRITE(*,*) ' [R] : error for transport linear solver'
+ END IF
+ IF (found(79,key_char//' maxiter lsolvec',line,.TRUE.)) THEN
+ READ(79,*,err=231,end=231) lmaxitc
+ WRITE(*,*) &
+ ' [R] : max-iter for transport linear solver'
+ END IF
+ IF (found(79,key_char//' name lsolvec',line,.TRUE.)) THEN
+ READ(79,'(A)') line
+ CALL read_solver(line,i,ismpl)
+ IF (i==-1) READ(line,*,err=232,end=232) i
+ WRITE(*,*) &
+ ' [R] : solver name for transport linear solver'
+ END IF
+ IF (found(79,key_char//' criteria lsolvec',line,.TRUE.)) THEN
+ READ(79,'(A)') line
+ CALL read_criteria(line,j,ismpl)
+ IF (j==-1) READ(line,*,err=233,end=233) j
+ WRITE(*,*) &
+ ' [R] : criteria for transport linear solver'
+ END IF
+ IF (found(79,key_char//' precondition lsolvec',line,.TRUE.)) THEN
+ READ(79,'(A)') line
+ CALL read_preco(line,k,ismpl)
+ IF (k==-1) READ(line,*,err=234,end=234) k
+ WRITE(*,*) &
+ ' [R] : precondition for transport linear solver'
+ END IF
+ CALL encntrl3(controlc,i,j,k)
+ END IF
+
+ IF (found(79,key_char//' nliterc',line,.TRUE.)) THEN
+ dtmp = -1.0D0
+ READ(79,*,err=103,end=103) nltolc, dtmp
+103 WRITE(*,*) &
+ ' [R] : transport nonlinear iteration tolerance'
+ IF (dtmp<0.0D0) THEN
+ WRITE(*,'(1A)') 'error: not reading relaxation factor!'
+ STOP
+ END IF
+ IF (nladapt==1) THEN
+ nlmaxc = dtmp
+ WRITE(*,*) ' [I] : max transport change/iteration'
+ ELSE
+ nlrelaxc = dtmp
+ WRITE(*,*) &
+ ' [I] : transport nonlinear relaxation factor'
+ END IF
+ END IF
+ ELSE
+ nltolc = 1.D-30
+ WRITE(*,*) ' '
+ WRITE(*,*) ' <D> : no transport [disabled]'
+ WRITE(*,*) ' '
+ END IF
+
+
+ WRITE(*,*) ' '
+ grav = 9.81D0
+ IF (found(79,key_char//' grav',line,.FALSE.)) THEN
+ READ(79,*,err=251,end=251) grav
+ WRITE(*,'(1a,1e12.4,1a)') ' [R] : grav', grav, &
+ ' (>1.0d-30)'
+ grav = max(grav,1.D-30)
+ ELSE
+ WRITE(*,'(1a,1e12.4)') ' <D> : grav = ', grav
+ END IF
+
+ hpf = 0.0D0
+ IF (found(79,key_char//' hpf',line,.FALSE.)) THEN
+ READ(79,*,err=252,end=252) hpf
+ WRITE(*,*) ' [R] : hpf, fluid heat production'
+ ELSE
+ WRITE(*,*) ' <D> : no fluid heat production'
+ END IF
+
+!#ifdef head_base
+ IF (found(79,key_char//' rref',line,.FALSE.)) THEN
+ READ(79,*) rref
+ WRITE(*,'(1a,1e12.4)') ' [R] : rref, reference density = ' &
+ , rref
+ ELSE
+ rref = 998.D0
+ WRITE(*,'(1a,1e12.4)') ' <D> : rref, reference density = ' &
+ , rref
+ END IF
+!#endif
+
+! if (found(79,'? tref',line,.false.)) then
+! read(79,*) tref
+! write(*,'(1a,1e12.4)')
+! & ' [R] : tref, referenCe temperature = ',tref
+! else
+ tref = 20.D0
+ WRITE(*,'(a,e12.4)') ' <D> : tref, reference temperature = ' &
+ , tref
+! endif
+
+ rhom = 2500D0
+ cma1 = 1.D0
+ cma2 = 0.D0
+ cma3 = 0.D0
+ IF (found(79,key_char//' rhocm',line,.FALSE.)) THEN
+ READ(79,*,err=253,end=253) rhom, cma1, cma2, cma3
+ WRITE(*,*) ' [R] : rhom, rock heat capacity model'
+ ELSE
+ WRITE(*,'(1A)') ' <D> : fixed rhocm, defined by unit'
+ END IF
+! normalise
+ IF (test_null(cma1)) THEN
+ WRITE(*,'(1A)') 'error: "cma1" equals to zero !!!'
+ STOP
+ ELSE
+ cma2 = cma2/cma1
+ cma3 = cma3/cma1
+ cma1 = 1.D0
+ END IF
+
+! before memory allocating, counting bc-tp entries ('ngsmax') needed
+ ngsmax = 1
+ nbctp = 0
+ IF (found(79,key_char//' bc time periods',line,.FALSE.)) THEN
+ CALL get_arg('records',line,i,j)
+ IF (i<1 .OR. j<i) THEN
+ READ(79,*,err=254,end=254) l
+ ELSE
+ READ(line(i:j),*) l
+ END IF
+ nbctp = l
+ DO i = 1, l
+! [bctp-unit, number of entries]
+ READ(79,*,err=255,end=255) k, j
+ nbctp = max(nbctp,k)
+ ngsmax = max(ngsmax,j)
+ DO k = 1, j
+! skip 'j' lines
+ READ(79,'(1A)') line
+ END DO
+ END DO
+ END IF
+
+! before memory allocating, counting bc-units entries ('nunits') nee
+ nunits = 0
+ IF (found(79,key_char//' bcunits',line,.FALSE.)) THEN
+ CALL get_arg('records',line,i,j)
+ IF (i<1 .OR. j<i) THEN
+ READ(79,*,err=256,end=256) tmplen
+ ELSE
+ READ(line(i:j),*) tmplen
+ END IF
+ DO i = 1, tmplen
+ READ(79,*,err=257,end=257) k, dtmp, ctmp
+ nunits = max(k,nunits)
+ END DO
+ END IF
+
+!----------------------------------------------------------------
+! zones
+ WRITE(*,*) ' '
+ WRITE(*,*) ' reading zone parameter '
+ WRITE(*,*) ' '
+
+! allocation here, because of the need for "nunits"
+ ALLOCATE(uindex(i0,j0,k0))
+ memory = memory + i0*j0*k0
+#ifndef noHDF
+ if (h5parse_use_hdf5_datafile) then
+ found_marker = .true.
+ call h5parse_read_3d_integer_dataset("uindex", uindex)
+ else
+#endif
+ IF (found(79,key_char//' uindex',line,.TRUE.)) THEN
+ IF (no_ext_link_int(i0,j0,k0,uindex,'uindex',line)) &
+ READ(79,*,err=110,end=110) (((uindex(i,j,k),i=1, &
+ i0),j=1,j0),k=1,k0)
+ found_marker = .true.
+ end if
+#ifndef noHDF
+ end if
+#endif
+ if (found_marker) then
+ found_marker = .false.
+ WRITE(*,*) ' [R] : "uindex" - unit index number, unit-cell assignment'
+
+ maxunits = uindex(1,1,1)
+ minunits = uindex(1,1,1)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ maxunits = max(uindex(i,j,k),maxunits)
+ minunits = min(uindex(i,j,k),minunits)
+ END DO
+ END DO
+ END DO
+
+ IF ((maxunits>i0*j0*k0) .OR. (minunits<1)) THEN
+ WRITE(*,'(A,I7,A,I7,A)') &
+ 'error: unit index out of range [', minunits, ',', &
+ maxunits, '] !'
+ STOP
+ END IF
+
+! also used as maximum for BC units ("bc_maxunits")
+ nunits = max(maxunits,nunits)
+
+! check thickness for each unit layer
+ CALL check_units(ismpl)
+ END IF
+
+ nbh_logs = 0
+ IF (found(79,key_char//' borehole log',line,.FALSE.)) THEN
+ CALL get_arg('records',line,i,j)
+ IF (i<1 .OR. j<i) THEN
+ READ(79,*,err=254,end=254) nbh_logs
+ ELSE
+ READ(line(i:j),*) nbh_logs
+ END IF
+ END IF
+
+! ------------------
+! initialisation for linear system solver
+! init array for prozessor grid, see more in 'solve/omp_preconditioniers.f'
+ CALL par_init2(I0,J0,K0)
+
+! ------------------
+! memory managment
+ WRITE(*,*) ' '
+ CALL alloc_arrays(ismpl)
+
+! ------------------
+! reading later
+ ndata = 0
+ WRITE(*,*) ' [R] : "units" - unit (rock) properties'
+ ALLOCATE(datmp(nprop_load,maxunits))
+! init property vaues to the default, needed when not enough values readed
+ DO j = 1, maxunits
+ DO i = 1, nprop_load
+ datmp(i,j) = prop_default(i)
+ END DO
+ END DO
+
+#ifndef noHDF
+ if (h5parse_use_hdf5_datafile) then
+ j = h5parse_read_dimension_size_for_dataset("units")
+ call h5parse_read_2d_double_dataset("units",datmp(1:j,:))
+ found_marker = .true.
+ else
+#endif
+ if (found(79,key_char//' units',line,.TRUE.)) then
+ IF (no_ext_link(nprop_load,maxunits,1,datmp,'units',line)) &
+ THEN
+ CALL read_array(79,nprop_load,maxunits,datmp,key_char//' units', &
+ ismpl)
+ END IF
+ found_marker = .true.
+ end if
+#ifndef noHDF
+ end if
+#endif
+ IF (found_marker) THEN
+ found_marker = .false.
+ IF (nprop_load==lastidx-firstidx+1) THEN
+! load all, dense entries (no specific index)
+ DO i = 1, maxunits
+ DO j = 1, nprop_load
+ propunit(i,firstidx-1+j,ismpl) = datmp(j,i)
+ END DO
+ END DO
+ ELSE
+! needs to handle manual reading with specific index
+ WRITE(*,'(1A)') &
+ 'error: bug (1) in "read_model.f", ask AW!'
+ STOP
+ END IF
+
+ IF (linfos(1)>=2 .AND. maxunits<=64) WRITE(*, &
+ '(1A18,'//c_npropunit//'(" ",1A4," "),1A6)') ' unit properties:', &
+ (properties(i),i=firstidx,lastidx), ' unit#'
+ DO i = 1, maxunits
+! because of logarithimc scale, suppress zeros
+ propunit(i,idx_por,ismpl) = max(prop_min(idx_por), &
+ propunit(i,idx_por,ismpl))
+ propunit(i,idx_an_kx,ismpl) = max(prop_min(idx_an_kx), &
+ propunit(i,idx_an_kx,ismpl))
+ propunit(i,idx_an_ky,ismpl) = max(prop_min(idx_an_ky), &
+ propunit(i,idx_an_ky,ismpl))
+ propunit(i,idx_kz,ismpl) = max(prop_min(idx_kz), &
+ propunit(i,idx_kz,ismpl))
+!? propunit(i,idx_comp,ismpl) = max(prop_min(idx_comp), &
+!? propunit(i,idx_comp,ismpl))
+ propunit(i,idx_an_lx,ismpl) = max(prop_min(idx_an_lx), &
+ propunit(i,idx_an_lx,ismpl))
+ propunit(i,idx_an_ly,ismpl) = max(prop_min(idx_an_ly), &
+ propunit(i,idx_an_ly,ismpl))
+ propunit(i,idx_lz,ismpl) = max(prop_min(idx_lz), &
+ propunit(i,idx_lz,ismpl))
+ propunit(i,idx_q,ismpl) = max(prop_min(idx_q), &
+ propunit(i,idx_q,ismpl))
+ propunit(i,idx_rc,ismpl) = max(prop_min(idx_rc), &
+ propunit(i,idx_rc,ismpl))
+ propunit(i,idx_df,ismpl) = max(prop_min(idx_df), &
+ propunit(i,idx_df,ismpl))
+ propunit(i,idx_ec,ismpl) = max(prop_min(idx_ec), &
+ propunit(i,idx_ec,ismpl))
+!? propunit(i,idx_lc,ismpl) = max(prop_min(idx_lc), &
+!? propunit(i,idx_lc,ismpl))
+ propunit(i,idx_s_nr,ismpl) = max(prop_min(idx_s_nr), &
+ propunit(i,idx_s_nr,ismpl))
+ propunit(i,idx_s_wr,ismpl) = max(prop_min(idx_s_wr), &
+ propunit(i,idx_s_wr,ismpl))
+ IF (linfos(1)>=2) WRITE(*,'(18X,'//c_npropunit//'e12.4,i6)') &
+ (propunit(i,j,ismpl),j=firstidx,lastidx), i
+ END DO
+
+ END IF
+ DEALLOCATE(datmp)
+
+! ------------------
+
+ IF (nbh_logs>0) THEN
+ IF (found(79,key_char//' borehole log',line,.FALSE.)) THEN
+ CALL get_arg('records',line,i,j)
+ IF (i<1 .OR. j<i) THEN
+ READ(79,*,err=254,end=254) i
+ ELSE
+ READ(line(i:j),*) i
+ END IF
+ IF (nbh_logs/=i) THEN
+ WRITE(*,*) 'error: more than one "borehole logs" section defined'
+ STOP
+ END IF
+ DO i = 1, nbh_logs
+! [x-position, y-position, bh-name]
+ READ(79,*,err=255,end=255) ibh_pos(1,i),ibh_pos(2,i),cbh_name(i)
+ END DO
+ END IF
+ END IF
+
+! ------------------
+
+ WRITE(*,*) ' '
+ WRITE(*,*) ' reading/preprocessing arrays'
+ WRITE(*,*) ' '
+
+ ijk = i0*j0*k0
+
+#ifndef noHDF
+ if (h5parse_use_hdf5_datafile) then
+ call h5parse_read_1d_double_dataset("grid/delx",delx,i0)
+ found_marker = .true.
+ else
+#endif
+ IF (found(79,key_char//' delx',line,.TRUE.)) THEN
+ IF (no_ext_link(i0,1,1,delx,'delx',line)) READ(79,*, &
+ err=260,end=260) (delx(i),i=1,i0)
+ found_marker = .true.
+ END IF
+#ifndef noHDF
+ end if
+#endif
+ if (found_marker) then
+ found_marker = .false.
+ WRITE(*,*) ' [R] : delx'
+ end if
+
+#ifndef noHDF
+ if (h5parse_use_hdf5_datafile) then
+ call h5parse_read_1d_double_dataset("grid/dely",dely,j0)
+ found_marker = .true.
+ else
+#endif
+ IF (found(79,key_char//' dely',line,.TRUE.)) THEN
+ IF (no_ext_link(1,j0,1,dely,'dely',line)) READ(79,*, &
+ err=261,end=261) (dely(j),j=1,j0)
+ found_marker = .true.
+ END IF
+#ifndef noHDF
+ end if
+#endif
+ if (found_marker) then
+ found_marker = .false.
+ WRITE(*,*) ' [R] : dely'
+ end if
+#ifndef noHDF
+ if (h5parse_use_hdf5_datafile) then
+ call h5parse_read_1d_double_dataset("grid/delz",delz,k0)
+ found_marker = .true.
+ else
+#endif
+ IF (found(79,key_char//' delz',line,.TRUE.)) THEN
+ IF (no_ext_link(1,1,k0,delz,'delz',line)) READ(79,*, &
+ err=262,end=262) (delz(k),k=1,k0)
+ found_marker = .true.
+ END IF
+#ifndef noHDF
+ end if
+#endif
+ if (found_marker) then
+ found_marker = .false.
+ WRITE(*,*) ' [R] : delz'
+ end if
+
+! compute absolute xyz-positions
+ delxa(1) = 0.5D0*delx(1)
+ DO i = 2, i0
+ delxa(i) = delxa(i-1) + 0.5D0*(delx(i-1)+delx(i))
+ END DO
+ delya(1) = 0.5D0*dely(1)
+ DO j = 2, j0
+ delya(j) = delya(j-1) + 0.5D0*(dely(j-1)+dely(j))
+ END DO
+ delza(1) = 0.5D0*delz(1)
+ DO k = 2, k0
+ delza(k) = delza(k-1) + 0.5D0*(delz(k-1)+delz(k))
+ END DO
+
+! initial values
+ WRITE(*,*) ' '
+ WRITE(*,*) ' reading initial values '
+ WRITE(*,*) ' '
+
+ head_needed = .false.
+#ifdef head_base
+ ! Head input forced for head computation
+ head_needed = .true.
+#endif
+ ! Is pres2head or head2pres needed for initial data
+ is_init_flow_trafo_needed = .true.
+
+#ifndef noHDF
+ if (h5parse_use_hdf5_datafile) then
+ if (h5parse_check_dataset_exist("init/head") .or. head_needed) then
+ call h5parse_read_3d_double_dataset("init/head", head(:,:,:,ismpl))
+ found_marker = .true.
+ end if
+ else
+#endif
+ IF (found(79,key_char//' head init',line,head_needed)) THEN
+ found_marker = .true.
+ IF (no_ext_link(i0,j0,k0,head(1,1,1, &
+ ismpl),'head',line)) READ(79,*,err=265,end=265) ((( &
+ head(i,j,k,ismpl),i=1,i0),j=1,j0),k=1,k0)
+ END IF
+#ifndef noHDF
+ end if
+#endif
+ if (found_marker) then
+ found_marker = .false.
+
+ ! Head input for pres_base: No trafo needed
+ if (.not.head_needed) is_init_flow_trafo_needed = .false.
+ write(*,*) ' [R] : head, in [m]'
+ end if
+
+#ifndef noHDF
+ if (h5parse_use_hdf5_datafile) then
+ call h5parse_read_3d_double_dataset("init/temp", temp(:,:,:,ismpl))
+ else
+#endif
+ IF (found(79,key_char//' temp init',line,.TRUE.)) THEN
+ IF (no_ext_link(i0,j0,k0,temp(1,1,1, &
+ ismpl),'temp',line)) READ(79,*,err=266,end=266) ((( &
+ temp(i,j,k,ismpl),i=1,i0),j=1,j0),k=1,k0)
+ END IF
+#ifndef noHDF
+ end if
+#endif
+ WRITE(*,*) ' [R] : temp, in [degree Celsius]'
+
+#ifndef noHDF
+ if (h5parse_use_hdf5_datafile) then
+ if (h5parse_check_dataset_exist("init/pres") .or. .not. head_needed) then
+ call h5parse_read_3d_double_dataset("init/pres", pres(:,:,:,ismpl))
+ found_marker = .true.
+ end if
+ else
+#endif
+ IF (found(79,key_char//' pres init',line,.NOT.head_needed)) THEN
+ found_marker = .true.
+ IF (no_ext_link(i0,j0,k0,pres(1,1,1, &
+ ismpl),'pres',line)) READ(79,*,err=267,end=267) ((( &
+ pres(i,j,k,ismpl),i=1,i0),j=1,j0),k=1,k0)
+ END IF
+#ifndef noHDF
+ end if
+#endif
+ if (found_marker) then
+ found_marker = .false.
+
+ ! Pres input for head_base: no trafo needed
+ if (head_needed) is_init_flow_trafo_needed = .false.
+ end if
+
+! convert [MPa] into [Pa]
+ CALL dscal(i0*j0*k0,pa_conv,pres(1,1,1,ismpl),1)
+ WRITE(*,*) ' [R] : pres, in [MPa]'
+
+ IF (trac_active) THEN
+ DO tracer = 1, ntrac
+ WRITE(strng,'(1A,1I4.4,1A)') key_char//' tracer', tracer, &
+ ' init'
+ CALL chln(strng,i1,i2)
+ IF (found(79,strng(i1:i2),line,.TRUE.)) THEN
+ IF (no_ext_link(i0,j0,k0,conc(1,1,1,tracer, &
+ ismpl),strng(i1+2:i2-5),line)) READ(79,*,err=268, &
+ end=268) (((conc(i,j,k,tracer,ismpl),i=1, &
+ i0),j=1,j0),k=1,k0)
+ WRITE(*,'(1A,1I4.4,1A)') ' [R] : tracer', tracer, &
+ ', in [Mol/l]'
+ END IF
+ END DO
+ END IF
+
+!----------------------------------------------------------------
+
+! boundary conditions if not on computional domain boundaries
+ WRITE(*,*) ' '
+ WRITE(*,*) ' reading boundary conditions '
+ WRITE(*,*) ' '
+
+! initialize current number of bc-units
+ bc_maxunits = 0
+ DO i = 1, nunits
+! init undefined max values
+ propunit(i,idx_hbc,ismpl) = const_dble(3)
+ propunit(i,idx_tbc,ismpl) = const_dble(3)
+ propunit(i,idx_cbc,ismpl) = const_dble(3)
+ propunit(i,idx_snbc,ismpl) = const_dble(3)
+ propunit(i,idx_ebc,ismpl) = const_dble(3)
+ END DO
+
+! read the entries of irregular boundary conditions
+ REWIND 79
+ posi = 0
+ ilost = 0
+#ifndef noHDF
+ if (h5parse_use_hdf5_datafile) then
+ do ijk = 1, 2
+ do i = 1, size(pv_name)
+ do k = 1, size(bc_name)
+ j=1
+ write(full_bc_name, '(A,"_",A,"_",I0)') pv_name(i), bc_name(k), j
+ do while (h5parse_check_dataset_exist("bc/"//full_bc_name))
+ if ((h5parse_check_attr_exist("simple", "bc/i"//full_bc_name) .and. ijk == 2) .or. &
+ & (.not. h5parse_check_attr_exist("simple", "bc/i"//full_bc_name) .and. ijk == 1)) then
+ CALL read_bc(79,full_bc_name,i,k,posi,ilost,ismpl)
+ end if
+ j = j+1
+ write(full_bc_name, '(A,"_",A,"_",I0)') pv_name(i), bc_name(k), j
+ end do
+ end do
+ end do
+ end do
+ else
+#endif
+ DO k = 1, nbc_sections
+20 READ(79,'(1A)',err=21,end=21) line
+ i = 0
+ j = 0
+ IF (locstr(line,key_char//' head bcd')==1 .AND. head_active) THEN
+ i = pv_head
+ j = bt_diri
+ ELSE IF (locstr(line,key_char//' head bcn')==1 .AND. head_active) THEN
+ i = pv_head
+ j = bt_neum
+ ELSE IF (locstr(line,key_char//' head bcw')==1 .AND. head_active) THEN
+ i = pv_head
+ j = bt_neuw
+ ELSE IF (locstr(line,key_char//' pres bcd')==1 .AND. pres_active) THEN
+ i = pv_pres
+ j = bt_diri
+ ELSE IF (locstr(line,key_char//' pres bcn')==1 .AND. pres_active) THEN
+ i = pv_pres
+ j = bt_neum
+ ELSE IF (locstr(line,key_char//' pres bcw')==1 .AND. pres_active) THEN
+ i = pv_pres
+ j = bt_neuw
+ ELSE IF (locstr(line,key_char//' temp bcd')==1 .AND. temp_active) THEN
+ i = pv_temp
+ j = bt_diri
+ ELSE IF (locstr(line,key_char//' temp bcn')==1 .AND. temp_active) THEN
+ i = pv_temp
+ j = bt_neum
+ ELSE IF (locstr(line,key_char//' conc bcd')==1 .AND. trans_active) THEN
+ i = pv_conc
+ j = bt_diri
+ ELSE IF (locstr(line,key_char//' conc bcn')==1 .AND. trans_active) THEN
+ i = pv_conc
+ j = bt_neum
+ END IF
+! bc line?
+ IF (i>0 .AND. j>0) THEN
+ CALL read_bc(79,line,i,j,posi,ilost,ismpl)
+ ELSE
+! try next line
+ GO TO 20
+ END IF
+ END DO
+#ifndef noHDF
+ end if
+#endif
+! sanity check
+21 IF (posi+ilost/=nbc_data) THEN
+ WRITE(*,'(1A)') &
+ 'error: lost some BC entries, in "read_model"!'
+ STOP
+ END IF
+! update 'nbc_data'
+ nbc_data = nbc_data - ilost
+
+! sort "*bc_data" and setup the first/last-index for all physical va
+ CALL sort_bc(ismpl)
+
+! print out dependency betwee bc and bctp
+ IF (linfos(1)>=1) THEN
+ CALL show_bcdep(ismpl)
+ WRITE(*,*) ' '
+ END IF
+!----------------------------------------------------------------
+
+ IF (bc_maxunits>0) THEN
+ IF (found(79,key_char//' bcunits',line,.TRUE.)) THEN
+
+ CALL get_arg('records',line,i,j)
+ IF (i<1 .OR. j<i) THEN
+ READ(79,*,err=256,end=256) tmplen
+ ELSE
+ READ(line(i:j),*) tmplen
+ END IF
+
+! mark the needed/used bc-units
+ ALLOCATE(ltmp(bc_maxunits,2))
+ DO i = 1, bc_maxunits
+! needed
+ ltmp(i,1) = .FALSE.
+! used
+ ltmp(i,2) = .FALSE.
+ END DO
+ DO i = 1, nbc_data
+ k = ibc_data(i,cbc_bcu)
+ IF (k>0) ltmp(k,1) = .TRUE.
+ END DO
+
+ IF (linfos(1)>=2) WRITE(*,'(A/2A12,A6)') &
+ ' bc unit properties:', ' unit# ', &
+ ' value ', ' type '
+ DO i = 1, tmplen
+ READ(79,*,err=257,end=257) k, dtmp, ctmp
+ IF ((k>bc_maxunits) .OR. (k<1)) THEN
+ WRITE(*,'(2A,1I3,1A,1I3,1A)') 'error: &
+ &in section "bcunits", unit number &
+ &out of', ' range, (', k, ') at line ', i, &
+ ' !!!'
+ STOP
+ END IF
+ IF ( .NOT. ltmp(k,1)) THEN
+ WRITE(*,'(2A,1I3,1A,1I3,1A)') &
+ 'warning: in section "bcunits", unit number', &
+ ' not used, (', k, ') at line ', i, '.'
+ END IF
+ ltmp(k,2) = .TRUE.
+ IF ((ctmp/='head') .AND. (ctmp/='pres') .AND. &
+ (ctmp/='temp') .AND. (ctmp/='conc')) THEN
+ WRITE(*,'(1A,1A4,1A,1I3,1A)') 'error: &
+ &in section "bcunits", bc type not &
+ &allowed, "', ctmp, '" at line ', i, ' !!!'
+ STOP
+ END IF
+
+! sanity checks
+ IF (ctmp=='head' .AND. propunit(k,idx_hbc,ismpl)/= &
+ const_dble(3)) THEN
+ WRITE(*,'(1A,1I7,1A)') 'error: head (/ pres) bc unit ', k, &
+ ' multi defined !!!'
+ STOP
+ END IF
+ IF (ctmp=='pres' .AND. propunit(k,idx_hbc,ismpl)/= &
+ const_dble(3)) THEN
+ WRITE(*,'(1A,1I7,1A)') 'error: pres (/ head) bc unit ', k, &
+ ' multi defined !!!'
+ STOP
+ END IF
+ IF (ctmp=='temp' .AND. propunit(k,idx_tbc,ismpl)/= &
+ const_dble(3)) THEN
+ WRITE(*,'(1A,1I7,1A)') 'error: temp bc unit ', k, &
+ ' multi defined !!!'
+ STOP
+ END IF
+ IF (ctmp=='conc' .AND. propunit(k,idx_cbc,ismpl)/= &
+ const_dble(3)) THEN
+ WRITE(*,'(1A,1I7,1A)') 'error: conc bc unit ', k, &
+ ' multi defined !!!'
+ STOP
+ END IF
+! update values
+ IF (ctmp=='head') propunit(k,idx_hbc,ismpl) = max(0.D0,dtmp)
+! convert [MPa] into [Pa]
+ IF (ctmp=='pres') propunit(k,idx_hbc,ismpl) = max(0.D0,dtmp*pa_conv)
+ IF (ctmp=='temp') propunit(k,idx_tbc,ismpl) = dtmp
+ IF (ctmp=='conc') propunit(k,idx_cbc,ismpl) = max(0.D0,dtmp)
+ IF (linfos(1)>=2) WRITE(*,'(I11,1X,1e12.4,1X,A4)') &
+ k, dtmp, ctmp
+ END DO
+ WRITE(*,'(A,I7)') &
+ ' [R] : bc unit properties, records=', tmplen
+ DO k = 1, bc_maxunits
+ IF (ltmp(k,1) .AND. .NOT. ltmp(k,2)) THEN
+ WRITE(*,'(2A,1I3,1A,1I3,1A)') &
+ 'error: in section "bcunits", unit number', &
+ ' not defined, (', k, ') !!!'
+ STOP
+ END IF
+ END DO
+ DEALLOCATE(ltmp)
+ END IF
+ END IF
+ DO i = 1, nunits
+! clear unread values
+ IF (propunit(i,idx_hbc,ismpl)==const_dble(3)) propunit(i,idx_hbc,ismpl) = 0.D0
+ IF (propunit(i,idx_tbc,ismpl)==const_dble(3)) propunit(i,idx_tbc,ismpl) = 0.D0
+ IF (propunit(i,idx_cbc,ismpl)==const_dble(3)) propunit(i,idx_cbc,ismpl) = 0.D0
+ IF (propunit(i,idx_snbc,ismpl)==const_dble(3)) propunit(i,idx_snbc,ismpl) = 0.D0
+ IF (propunit(i,idx_ebc,ismpl)==const_dble(3)) propunit(i,idx_ebc,ismpl) = 0.D0
+ END DO
+
+ IF (trans_active) THEN
+ IF (found(79,key_char//' transpar',line,.FALSE.)) THEN
+ DO i = 1, ntrans
+ READ(79,*,err=270,end=270) diff_c(i), mmas_c(i)
+ END DO
+ WRITE(*,'(1A,1I6,1A)') ' [R] : ', ntrans, &
+ ' diffusion constants and mol masses'
+ ELSE
+ dtmp = 1.D-9
+ DO i = 1, ntrans
+ diff_c(i) = dtmp
+ mmas_c(i) = mmas_nacl
+ END DO
+ WRITE(*,*) ' <D> : uniform diffusion constant = ', &
+ dtmp
+ END IF
+ END IF
+
+
+ IF (found(79,key_char//' prop limit',line,.FALSE.)) THEN
+ WRITE(*,*) ' [R] : property limitations'
+ CALL get_arg('records',line,i,j)
+ IF (i<1 .OR. j<i) THEN
+ READ(79,*,err=280,end=280) tmplen
+ ELSE
+ READ(line(i:j),*) tmplen
+ END IF
+ DO i = 1, tmplen
+ READ(79,'(a)',err=281,end=281) line
+ CALL read_limit(line)
+ END DO
+ ELSE
+ WRITE(*,*) ' <D> : property limitations'
+ END IF
+
+ IF (found(79,key_char//' velocity',line,.FALSE.)) THEN
+ ALLOCATE(vdefault(3,nsmpl))
+
+ WRITE(*,*) ' [R] : default Darcy velocity'
+ READ(79,*,err=282,end=282) vdefault(1,1), vdefault(2,1), vdefault(3,1)
+ WRITE(*,*) ' [R] : [x:vdefault(1,1), y:vdefault(2,1), z:vdefault(3,1)] = [', &
+ vdefault(1,1), ',', vdefault(2,1), ',', vdefault(3,1), ']'
+ vdefaultswitch = .true.
+
+ DO i = 2, nsmpl
+ vdefault(1,i) = vdefault(1,1)
+ vdefault(2,i) = vdefault(2,1)
+ vdefault(3,i) = vdefault(3,1)
+ END DO
+ ELSE
+ WRITE(*,'(1A)') &
+ ' [R] : Zero default Darcy velocity - no # velocity!'
+ vdefaultswitch = .false.
+ END IF
+
+! if (found(79,key_char//' pumping',line,.false.)) then
+! Call get_arg('reCords',line,i,j)
+! if (i.lt.1.or.j.lt.i) then
+! read(79,*) templen
+! else
+! read(line(i:j),*) templen
+! endif
+! npump=templen
+! do i = 1, npump
+! read(79,*) (tocell(j,i),j=1,3), (fromcell(j,i),j=1,3), howmuch(i)
+! end do
+! write(*,'(1A,1I6,1A)')
+! & ' [R] : ',npump,' pumping/reinjeCtion setups'
+! else
+! write(*,*) ' <D> : no pumping/reinjeCtion setups '
+! endif
+
+! clean node info
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ node_info(i,j,k) = ' '
+! node_info(i,j,k)(pv_head:pv_head) = ' '
+! node_info(i,j,k)(pv_temp:pv_temp) = ' '
+! node_info(i,j,k)(pv_conc:pv_conc) = ' '
+! node_info(i,j,k)(pv_pres:pv_pres) = ' '
+ END DO
+ END DO
+ END DO
+! init node info
+ DO l = 1, nbc_data
+ i = ibc_data(l,cbc_i)
+ j = ibc_data(l,cbc_j)
+ k = ibc_data(l,cbc_k)
+ sbc = ' '
+ IF (ibc_data(l,cbc_bt)==bt_diri) sbc = 'd'
+ IF (ibc_data(l,cbc_bt)==bt_neum) sbc = 'n'
+ IF (ibc_data(l,cbc_bt)==bt_neuw) sbc = 'w'
+ node_info(i,j,k) (ibc_data(l,cbc_pv):ibc_data(l,cbc_pv)) &
+ = sbc
+ END DO
+
+! ------------------
+
+! finish HDF5 support, when available
+ CALL close_hdf5()
+
+! close project config file
+ CLOSE(79)
+
+ RETURN
+
+! error handler
+110 WRITE(*,'(1A,3I7,1A)') &
+ 'error: reading section "uindex", at index [', i, j, k, &
+ ']!'
+ STOP
+200 WRITE(*,'(1A)') 'error: can not read "title"!'
+ STOP
+201 WRITE(*,'(1A)') &
+ 'error: can not read number of "samples"!'
+ STOP
+202 WRITE(*,'(1A)') 'error: can not read "runmode"!'
+ STOP
+203 WRITE(*,'(1A)') &
+ 'error: can not read dimensions in section "grid"!'
+ STOP
+204 WRITE(*,'(2A)') 'error: in section "nlsolve" expecting:', &
+ ' <max iter> <adapting switch = {0,1}>!'
+ STOP
+205 WRITE(*,'(2A)') 'error: no size specified for some ', &
+ '"boundary condition definition"!'
+ STOP
+206 WRITE(*,'(1A)') &
+ 'error: can not find section "'//key_char//' PROPS=<...>"!'
+ STOP
+207 WRITE(*,'(1A)') &
+ 'error: can not find section "'//key_char//' USER=<...>"!'
+ STOP
+210 WRITE(*,'(1A)') &
+ 'error: no definition for "error lsolvef"!'
+ STOP
+211 WRITE(*,'(1A)') &
+ 'error: no definition for "maxiter lsolvef"!'
+ STOP
+212 WRITE(*,'(1A)') &
+ 'error: no definition for "name lsolvef"!'
+ STOP
+213 WRITE(*,'(1A)') &
+ 'error: no definition for "criteria lsolvef"!'
+ STOP
+214 WRITE(*,'(1A)') &
+ 'error: no definition for "precondition lsolvef"!'
+ STOP
+215 WRITE(*,'(1A)') &
+ 'error: file end after section "disable output"!'
+ STOP
+220 WRITE(*,'(1A)') &
+ 'error: no definition for "error lsolvet"!'
+ STOP
+221 WRITE(*,'(1A)') &
+ 'error: no definition for "maxiter lsolvet"!'
+ STOP
+222 WRITE(*,'(1A)') &
+ 'error: no definition for "name lsolvet"!'
+ STOP
+223 WRITE(*,'(1A)') &
+ 'error: no definition for "criteria lsolvet"!'
+ STOP
+224 WRITE(*,'(1A)') &
+ 'error: no definition for "precondition lsolvet"!'
+ STOP
+250 WRITE(*,'(1A)') 'error: in section "ntrans"', &
+ ' expecting: <#tracer> <#chemicals>!'
+ STOP
+230 WRITE(*,'(1A)') &
+ 'error: no definition for "error lsolvec"!'
+ STOP
+231 WRITE(*,'(1A)') &
+ 'error: no definition for "maxiter lsolvec"!'
+ STOP
+232 WRITE(*,'(1A)') &
+ 'error: no definition for "name lsolvec"!'
+ STOP
+233 WRITE(*,'(1A)') &
+ 'error: no definition for "criteria lsolvec"!'
+ STOP
+234 WRITE(*,'(1A)') &
+ 'error: no definition for "precondition lsolvec"!'
+ STOP
+251 WRITE(*,'(1A)') &
+ 'error: can not read gravity in section "grav"!'
+ STOP
+252 WRITE(*,'(1A)') &
+ 'error: can not read the value in section "hpf"!'
+ STOP
+253 WRITE(*,'(1A)') 'error: in section "rhocm"', &
+ 'expecting: "rhom cma1 cma2 cma3"!'
+ STOP
+254 WRITE(*,'(1A)') &
+ 'error: no size specified for "bc time periods"!'
+ STOP
+255 WRITE(*,'(2A)') 'error: in data section of "bc time periods",',&
+ ' expecting:',' <unit-id> <number of entries>!'
+ STOP
+256 WRITE(*,'(1A)') 'error: no size specified for "bcunits"!'
+ STOP
+257 WRITE(*,'(1A)') 'error: in data section of "bcunits"', &
+ 'please read manual!'
+ STOP
+260 WRITE(*,'(1A)') 'error: to few values in section "delx"!'
+ STOP
+261 WRITE(*,'(1A)') 'error: to few values in section "dely"!'
+ STOP
+262 WRITE(*,'(1A)') 'error: to few values in section "delz"!'
+ STOP
+265 WRITE(*,'(1A)') &
+ 'error: to few values in section "head init"!'
+ STOP
+266 WRITE(*,'(1A)') &
+ 'error: to few values in section "temp init"!'
+ STOP
+267 WRITE(*,'(1A)') &
+ 'error: to few values in section "pres init"!'
+ STOP
+268 WRITE(*,'(1A)') &
+ 'error: to few values in section "tracer**** init"!'
+ STOP
+270 WRITE(*,'(1A)') &
+ 'error: to few values in section "transpar"!'
+ STOP
+280 WRITE(*,'(1A)') &
+ 'error: can not read number of limits in section "prop limit"!'
+ STOP
+281 WRITE(*,'(1A)') &
+ 'error: to few lines in section "prop limit"!'
+ STOP
+282 WRITE(*,'(1A)') &
+ 'error: wrong specification of default velocity!'
+ STOP
+ END
+
+!> @brief print out the dependency between bc and tpbc
+!> @param[in] ismpl local sample index
+ SUBROUTINE show_bcdep(ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+ character (len=800) :: line
+ INTEGER i_bcu, i_bctp
+
+! print bc and bctp dependency
+ i_bcu = -1
+ i_bctp = -1
+ DO i = 1, nbc_data
+! max bc-unit index
+ i_bcu = max(i_bcu,ibc_data(i,cbc_bcu))
+! max bctp index
+ i_bctp = max(i_bctp,ibc_data(i,cbc_bctp))
+ END DO
+ IF (i_bcu>=0 .AND. i_bctp>=1) THEN
+ WRITE(*,*) ' '
+ WRITE(*,'(6X,A)') 'dependency matrix [time &
+ &depended boundary condition]:'
+ WRITE(line,'(100(I8,1X))') (i,i=1,i_bctp)
+ WRITE(*,'(8X,1A14,1A,1A1)') '|BCunit| bctp:', &
+ line(1:i_bctp*11), '|'
+ DO i = 0, i_bcu
+ line = ' '
+ DO j = 1, nbc_data
+ k = (ibc_data(j,cbc_bctp)-1)*9 + 1
+ IF (ibc_data(j,cbc_bcu)==i .AND. &
+ ibc_data(j,cbc_bctp)>=1 .AND. &
+ ibc_data(j,cbc_pv)==pv_head .AND. &
+ ibc_data(j,cbc_bt)==bt_diri) line(k+1:k+2) = 'Hd'
+ IF (ibc_data(j,cbc_bcu)==i .AND. &
+ ibc_data(j,cbc_bctp)>=1 .AND. &
+ ibc_data(j,cbc_pv)==pv_head .AND. &
+ ibc_data(j,cbc_bt)==bt_neum) line(k+1:k+2) = 'Hn'
+ IF (ibc_data(j,cbc_bcu)==i .AND. &
+ ibc_data(j,cbc_bctp)>=1 .AND. &
+ ibc_data(j,cbc_pv)==pv_head .AND. &
+ ibc_data(j,cbc_bt)==bt_neuw) line(k+1:k+2) = 'Hw'
+ IF (ibc_data(j,cbc_bcu)==i .AND. &
+ ibc_data(j,cbc_bctp)>=1 .AND. &
+ ibc_data(j,cbc_pv)==pv_pres .AND. &
+ ibc_data(j,cbc_bt)==bt_diri) line(k+1:k+2) = 'Pd'
+ IF (ibc_data(j,cbc_bcu)==i .AND. &
+ ibc_data(j,cbc_bctp)>=1 .AND. &
+ ibc_data(j,cbc_pv)==pv_pres .AND. &
+ ibc_data(j,cbc_bt)==bt_neum) line(k+1:k+2) = 'Pn'
+ IF (ibc_data(j,cbc_bcu)==i .AND. &
+ ibc_data(j,cbc_bctp)>=1 .AND. &
+ ibc_data(j,cbc_pv)==pv_pres .AND. &
+ ibc_data(j,cbc_bt)==bt_neuw) line(k+1:k+2) = 'Pw'
+ IF (ibc_data(j,cbc_bcu)==i .AND. &
+ ibc_data(j,cbc_bctp)>=1 .AND. &
+ ibc_data(j,cbc_pv)==pv_temp .AND. &
+ ibc_data(j,cbc_bt)==bt_diri) line(k+3:k+4) = 'Td'
+ IF (ibc_data(j,cbc_bcu)==i .AND. &
+ ibc_data(j,cbc_bctp)>=1 .AND. &
+ ibc_data(j,cbc_pv)==pv_temp .AND. &
+ ibc_data(j,cbc_bt)==bt_neum) line(k+3:k+4) = 'Tn'
+ IF (ibc_data(j,cbc_bcu)==i .AND. &
+ ibc_data(j,cbc_bctp)>=1 .AND. &
+ ibc_data(j,cbc_pv)==pv_conc .AND. &
+ ibc_data(j,cbc_bt)==bt_diri) line(k+5:k+6) = 'Cd'
+ IF (ibc_data(j,cbc_bcu)==i .AND. &
+ ibc_data(j,cbc_bctp)>=1 .AND. &
+ ibc_data(j,cbc_pv)==pv_conc .AND. &
+ ibc_data(j,cbc_bt)==bt_neum) line(k+5:k+6) = 'Cn'
+ END DO
+ WRITE(*,'(8X,1A2,1I4,1A2,6X,1A,1A1)') '| ', i, ' |', &
+ line(1:i_bctp*11), '|'
+ END DO
+ END IF
+!
+ RETURN
+ END
+
+!> @brief read all solver parameter
+!> @param[in] line current character line
+!> @param[out] errft break value (error)
+!> @param[out] controlft solver code
+!> @param[out] lmaxitft max iteration number for lin. system solver
+!> @param[in] ismpl local sample index
+ SUBROUTINE read_solvpar(line,errft,controlft,lmaxitft,ismpl)
+ IMPLICIT NONE
+ character (len=80) :: line
+ DOUBLE PRECISION errft
+ INTEGER controlft, lmaxitft, ismpl
+ INTEGER i, j, c1, c2, c3, clast, beginlast
+ EXTERNAL clast, beginlast
+
+ CALL read_solver(line,c1,ismpl)
+ CALL read_criteria(line,c2,ismpl)
+! default: auto
+ IF (c2==-1) c2 = 4
+ CALL read_preco(line,c3,ismpl)
+! default: ILU
+ IF (c3==-1) c3 = 0
+!
+ IF (c1==-1) THEN
+ READ(line,*) errft, controlft, lmaxitft
+ ELSE
+ CALL encntrl3(controlft,c1,c2,c3)
+ READ(line,*) errft
+ j = clast(line)
+ i = beginlast(line(1:j))
+ READ(line(i:j),*) lmaxitft
+ END IF
+!
+ RETURN
+ END
+
+!> @brief read the solver type
+!> @param[in] line current character line
+!> @param[out] c1 linear system solver code
+!> @param[in] ismpl local sample index
+ SUBROUTINE read_solver(line,c1,ismpl)
+ IMPLICIT NONE
+ character (len=80) :: line
+ INTEGER i, c1, ismpl, locstr
+ EXTERNAL locstr
+
+ c1 = -1
+! check CG before BiCGStab, because CG is a substring
+ i = locstr(line,'cg')
+ IF (i>=1) c1 = 2
+ i = locstr(line,'bicg')
+ IF (i>=1) c1 = 0
+ i = locstr(line,'nag')
+ IF (i>=1) c1 = 1
+ i = locstr(line,'plu')
+ IF (i>=1) c1 = 3
+!
+ RETURN
+ END
+
+!> @brief read the solver break criteria
+!> @param[in] line current character line
+!> @param[out] c2 break criteria code
+!> @param[in] ismpl local sample index
+ SUBROUTINE read_criteria(line,c2,ismpl)
+ IMPLICIT NONE
+ character (len=80) :: line
+ INTEGER i, c2, ismpl, locstr
+ EXTERNAL locstr
+
+ c2 = -1
+ i = locstr(line,'rel')
+ IF (i>=1) c2 = 0
+ i = locstr(line,'abs')
+ IF ((i>=1) .AND. (c2/=0)) c2 = 1
+! Rel + Abs
+ IF ((i>=1) .AND. (c2==0)) c2 = 3
+ i = locstr(line,'max')
+ IF (i>=1) c2 = 2
+ i = locstr(line,'auto')
+ IF (i>=1) c2 = 4
+!
+ RETURN
+ END
+
+!> @brief read the preconditioner type
+!> @param[in] line current character line
+!> @param[out] c3 preconditioner code
+!> @param[in] ismpl local sample index
+ SUBROUTINE read_preco(line,c3,ismpl)
+ IMPLICIT NONE
+ character (len=80) :: line
+ INTEGER i, c3, ismpl, locstr
+ EXTERNAL locstr
+
+ c3 = -1
+ i = locstr(line,'ilu')
+ IF (i>=1) c3 = 0
+ i = locstr(line,'ssor')
+ IF (i>=1) c3 = 1
+ i = locstr(line,'diag')
+ IF (i>=1) c3 = 2
+ i = locstr(line,'none')
+ IF (i>=1) c3 = 3
+!
+ RETURN
+ END
+
+!> @brief read the direction-type
+!> @param[in] richtung direction string
+!> @return direction code
+ INTEGER FUNCTION read_direction(richtung)
+ IMPLICIT NONE
+ character (len=*) :: richtung
+ INTEGER locstr
+ EXTERNAL locstr
+
+ read_direction = 0
+ IF (locstr(richtung,'none')==1) read_direction = 0
+ IF (locstr(richtung,'0')==1) read_direction = 0
+ IF (locstr(richtung,'left')==1) read_direction = 1
+ IF (locstr(richtung,'1')==1) read_direction = 1
+ IF (locstr(richtung,'right')==1) read_direction = 2
+ IF (locstr(richtung,'2')==1) read_direction = 2
+ IF (locstr(richtung,'front')==1) read_direction = 3
+ IF (locstr(richtung,'3')==1) read_direction = 3
+ IF (locstr(richtung,'back')==1) read_direction = 4
+ IF (locstr(richtung,'4')==1) read_direction = 4
+ IF (locstr(richtung,'base')==1) read_direction = 5
+ IF (locstr(richtung,'5')==1) read_direction = 5
+ IF (locstr(richtung,'top')==1) read_direction = 6
+ IF (locstr(richtung,'6')==1) read_direction = 6
+!
+ RETURN
+ END
+
+#ifdef DEBUG
+!> @brief debug: read additional output times
+!> @param[in] ismpl local sample index
+ SUBROUTINE read_debugout(ismpl)
+ use arrays
+ use mod_genrl
+ IMPLICIT NONE
+ character (len=80) :: line
+ INTEGER i, j, ismpl
+ LOGICAL found
+ EXTERNAL found
+
+ IF (found(79,key_char//' debug output times',line,.FALSE.)) THEN
+ CALL get_arg('records',line,i,j)
+ IF (i<1 .OR. j<i) THEN
+ READ(79,*) n_debugout
+ ELSE
+ READ(line(i:j),*) n_debugout
+ END IF
+ ALLOCATE(debugout(2,n_debugout))
+ DO i = 1, n_debugout
+ READ(79,*) (debugout(j,i),j=1,2)
+ END DO
+ WRITE(*,'(1A,1I4)') ' [R] : debug output, records=', &
+ n_debugout
+ ELSE
+ WRITE(*,'(1A,1I4)') &
+ ' [I] : no additional debug output'
+! dummy allocation
+ ALLOCATE(debugout(1,1))
+ END IF
+!
+ RETURN
+ END
+#endif
+
+!> @brief read the property output switch
+!> @param[in] line current character line
+ SUBROUTINE read_oprop(line)
+ use arrays
+ IMPLICIT NONE
+ character (len=*) :: line
+ INTEGER i, l, locstr, ibegin, iend
+ EXTERNAL locstr
+
+ DO i = firstidx, bc_lastidx
+ CALL chln(properties(i),ibegin,iend)
+ l = locstr(line,properties(i)(ibegin:iend))
+ IF (l>=1) out_prop(i) = .FALSE.
+ END DO
+!
+ WRITE(*,*) ' [I] : HDF5 output configuration'
+ WRITE(*,'(1A,'//c_npropunit//'A5)') ' ', (properties(i),i=firstidx,lastidx)
+ WRITE(*,'(1A,'//c_npropunit//'L5)') ' ', (out_prop(i),i=firstidx,lastidx)
+!
+ WRITE(*,'(1A,'//c_nbcunit//'A5)') ' ', (properties(i),i=bc_firstidx,bc_lastidx)
+ WRITE(*,'(1A,'//c_nbcunit//'L5)') ' ', (out_prop(i),i=bc_firstidx,bc_lastidx)
+!
+ RETURN
+ END
+
+!> @brief read the physical-value output switch
+!> @param[in] line current character line
+ SUBROUTINE read_opv(line)
+ use arrays
+ IMPLICIT NONE
+ character (len=*) :: line
+ INTEGER i, l, locstr, ibegin, iend
+ EXTERNAL locstr
+
+ DO i = 1, npv
+ CALL chln(pv_name(i),ibegin,iend)
+ l = locstr(line,pv_name(i)(ibegin:iend))
+ IF (l>=1) out_pv(i) = .FALSE.
+ END DO
+!
+ WRITE(*,'(1A,'//c_npv//'A5)') ' ', (pv_name(i),i=1,npv)
+ WRITE(*,'(1A,'//c_npv//'L5)') ' ', (out_pv(i),i=1,npv)
+!
+ RETURN
+ END
+
+!> @brief read the xyz-position output switch
+!> @param[in] line current character line
+ SUBROUTINE read_oijk(line)
+ use arrays
+ IMPLICIT NONE
+ character (len=*) :: line
+ INTEGER i, l, locstr, ibegin, iend
+ EXTERNAL locstr
+ character (len=6) :: ijk_name(nout_ijk)
+ DATA ijk_name/' px', ' py', ' pz', ' vx', &
+ ' vy', ' vz', ' rhof', ' visf', 'uindex'/
+
+ DO i = 1, nout_ijk
+ CALL chln(ijk_name(i),ibegin,iend)
+ l = locstr(line,ijk_name(i)(ibegin:iend))
+ IF (l>=1) out_ijk(i) = .FALSE.
+ END DO
+!
+ WRITE(*,'(1A,9A7)') ' ', (ijk_name(i),i=1,nout_ijk)
+ WRITE(*,'(1A,9L7)') ' ', (out_ijk(i),i=1,nout_ijk)
+!
+ RETURN
+ END
+
+!> @brief read property limits
+!> @param[in] line current character line
+ SUBROUTINE read_limit(line)
+ USE ARRAYS
+ IMPLICIT NONE
+ character (len=*) :: line
+ character (len=8) :: skey
+ INTEGER i, j, locstr, lblank
+ EXTERNAL locstr, lblank
+ INTRINSIC adjustl, trim
+
+! search the parameter key-name
+ j = 0
+ DO i = 1, nprop_load
+ skey = adjustl(properties(i))
+ IF (locstr(line,skey(1:lblank(skey)))>=1) j = i
+ END DO
+ IF (j>=1) THEN
+! MIN or MAX limitation
+ IF (locstr(line,'min')>=1) THEN
+ READ(line,*) prop_min(j)
+ ELSE IF (locstr(line,'max')>=1) THEN
+ READ(line,*) prop_max(j)
+ ELSE
+ WRITE(*,'(4A)') 'error: wrong limit specification (min|max)', &
+ ' in section "prop limit" line: "',trim(line),'"!'
+ STOP
+ ENDIF
+ ELSE
+ WRITE(*,'(4A)') 'error: wrong parameter keyword in section', &
+ ' "prop limit" line: "',trim(line),'"!'
+ STOP
+ ENDIF
+!
+ RETURN
+ END
diff --git a/forward/input/read_property.f90 b/forward/input/read_property.f90
new file mode 100644
index 0000000..1d0d3a3
--- /dev/null
+++ b/forward/input/read_property.f90
@@ -0,0 +1,76 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief read and overwrites a specific rock property (only full dimension is supported)
+!> @param[in] filename "model" (or other) file name
+!> @param[in] prop_idx property index number
+!> @param[in] ismpl local sample index
+ SUBROUTINE read_property(filename,prop_idx,ismpl)
+ use arrays
+ use mod_genrl
+ IMPLICIT NONE
+!
+ INTEGER ismpl, i, j, k
+ character (len=80) :: filename
+ character (len=80) :: line
+ character (len=10) :: pname
+ INTEGER prop_idx
+!
+ LOGICAL found, no_ext_link
+ EXTERNAL found, no_ext_link
+ INTRINSIC trim, adjustl
+
+!
+ IF (prop_idx<firstidx .OR. prop_idx>lastidx) THEN
+ WRITE(*,'(1A,3(1I2,1A))') 'error: property index number ',prop_idx,' out of range (',firstidx,',',lastidx,')!'
+ STOP
+ END IF
+!
+ pname = trim(adjustl(properties(prop_idx)))
+ WRITE(*,*) ' [R] : '//trim(doc_properties(prop_idx))//' ('//trim(pname)//') from file "', trim(filename),'"'
+! read file
+ OPEN(79,file=filename,status='old')
+! init HDF5 support, when available
+ CALL open_hdf5(' ')
+!
+ IF (found(79,key_char//' '//trim(pname),line,.TRUE.)) THEN
+ IF (no_ext_link(i0,j0,k0,x(1,1,1,ismpl),trim(pname),line)) &
+ READ(79,*,err=200,end=200) (((x(i,j,k,ismpl),i=1,i0),j=1,J0),k=1,K0)
+ DO k = 1, K0
+ DO j = 1, J0
+ DO i = 1, I0
+ propunit(uindex(i,j,k),prop_idx,ismpl) = x(i,j,k,ismpl)
+ END DO
+ END DO
+ END DO
+ END IF
+!
+! finish HDF5 support, when available
+ CALL close_hdf5()
+! close project config file
+ CLOSE(79)
+ RETURN
+
+! error handler
+200 WRITE(*,'(3A)') 'error: to few values in section "',trim(pname),'"!'
+ STOP
+ END
diff --git a/forward/input/read_split.f90 b/forward/input/read_split.f90
new file mode 100644
index 0000000..e1c539a
--- /dev/null
+++ b/forward/input/read_split.f90
@@ -0,0 +1,142 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief read unit spliting
+!> @param[in] filename file name
+!> @param[in] ismpl local sample index
+!> @details
+!> read configuration for splitting some units,\n
+!> split each former unit (layer) into different units for each cell\n
+ SUBROUTINE read_split(filename,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k, l
+
+ character (len=80) :: filename
+ character (len=80) :: line
+ INTEGER nsplit, msplit
+ ! INTEGER munits
+ INTEGER nn
+
+ INTEGER, ALLOCATABLE :: isplit(:), sindex(:)
+! copy fields
+ ! INTEGER, ALLOCATABLE :: itmp(:,:)
+ DOUBLE PRECISION, ALLOCATABLE :: dtmp(:,:)
+
+ INTEGER lblank
+ LOGICAL found
+ EXTERNAL lblank, found
+
+
+! open project Config file
+ OPEN(79,file=filename,status='old')
+
+ IF (found(79,key_char//' split units',line,.FALSE.)) THEN
+ WRITE(*,*) ' '
+ WRITE(*,*) ' reading splitting parameter:'
+ WRITE(*,*) ' from file "', filename(:lblank(filename)), &
+ '"'
+ WRITE(*,*) ' '
+
+ CALL get_arg('records',line,i,j)
+ IF (i<1 .OR. j<i) THEN
+ READ(79,*) nsplit
+ ELSE
+ READ(line(i:j),*) nsplit
+ END IF
+ ALLOCATE(isplit(nsplit))
+ READ(79,*) (isplit(i),i=1,nsplit)
+ WRITE(*,'(1A,1I4,1A)') ' [I] : splitting for ', nsplit, &
+ ' unit(s)'
+
+ ALLOCATE(sindex(i0*j0*k0+nunits))
+ DO l = 1, nunits
+ sindex(l) = l
+ END DO
+! count the number of unit-elements
+ msplit = nunits
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ DO l = 1, nsplit
+ IF (uindex(i,j,k)==isplit(l)) THEN
+ msplit = msplit + 1
+ sindex(msplit) = uindex(i,j,k)
+ uindex(i,j,k) = msplit
+! break the search loop
+ GO TO 100
+ END IF
+ END DO
+100 CONTINUE
+ END DO
+ END DO
+ END DO
+ WRITE(*,'(1A,1I9)') ' [I] : (splitted) units = ', msplit
+
+! # propunit
+ nn = nprop*nsmpl
+ ALLOCATE(dtmp(nunits,nn))
+! save values
+ CALL dcopy(nunits*nn,propunit,1,dtmp,1)
+! reallocate space
+ DEALLOCATE(propunit)
+ ALLOCATE(propunit(msplit,nprop,nsmpl))
+ memory = memory - nunits*nn
+ memory = memory + msplit*nn
+! split elements, execption for "propunit", because of the bc-parts
+! over all elements, normal units
+ DO k = 1, nsmpl
+ DO j = firstidx, lastidx
+ l = j + nprop*(k-1)
+ DO i = 1, msplit
+! copy old values for new unit
+ propunit(i,j,k) = dtmp(sindex(i),l)
+ END DO
+ END DO
+ END DO
+! over all elements, bc units
+ DO k = 1, nsmpl
+ DO j = bc_firstidx, bc_lastidx
+ l = j + nprop*(k-1)
+ DO i = 1, bc_maxunits
+! copy old values for new unit
+ propunit(i,j,k) = dtmp(i,l)
+ END DO
+ END DO
+ END DO
+ DEALLOCATE(dtmp)
+
+ DEALLOCATE(sindex)
+ DEALLOCATE(isplit)
+ maxunits = msplit
+ nunits = msplit
+ END IF
+
+! close project config file
+ CLOSE(79)
+
+ RETURN
+ END
diff --git a/forward/input/read_time.f90 b/forward/input/read_time.f90
new file mode 100644
index 0000000..6e38b80
--- /dev/null
+++ b/forward/input/read_time.f90
@@ -0,0 +1,612 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief read time parameter
+!> @param[in] filename model file name
+!> @param[in] ismpl local sample index
+!> @details
+!> Note: To be able to use input file parsing with hdf5, the
+!> hdf5-input-files have to be generated using the script:
+!> `convert_to_hdf5.py`. This script can be found in the repository
+!> `SHEMAT-Suite_Scripts` under
+!> `python/preprocessing/convert_to_hdf5.py`.
+ SUBROUTINE read_time(filename,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_flow
+ use mod_temp
+ use mod_conc
+ use mod_time
+ use mod_data
+ use mod_linfos
+#ifndef noHDF
+ use mod_input_file_parser_hdf5
+#endif
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k, l
+!
+ character (len=80) :: filename
+ character (len=80) :: line
+!
+ INTEGER lblank, id, num, step_type, locstr
+ LOGICAL found, no_ext_link, no_ext_link_int
+ EXTERNAL found, no_ext_link, no_ext_link_int, lblank, locstr
+
+ logical :: found_marker = .false.
+
+
+ WRITE(*,*)
+ WRITE(*,*) ' reading time input parameter:'
+ WRITE(*,*) ' from file "', filename(:lblank(filename)), &
+ '"'
+ WRITE(*,*)
+
+! read file
+ OPEN(79,file=filename,status='old')
+
+! init HDF5 support, when available
+ CALL open_hdf5(' ')
+
+! ------------------
+ transient = .FALSE.
+ thetaf = 1.D0
+ thetat = 1.D0
+! start of the simulation time
+ simtime(ismpl) = 0.D0
+#ifndef noHDF
+ if (h5parse_use_hdf5_datafile) then
+ if (h5parse_check_attr_exist("thetaf","time")) then
+ call h5parse_read_double_attribute("thetaf", thetaf, "time")
+ call h5parse_read_double_attribute("thetat", thetat, "time")
+ call h5parse_read_double_attribute("thetac", thetac, "time")
+ call h5parse_read_double_attribute("tstart", simtime(ismpl), "time")
+ found_marker = .true.
+ end if
+ else
+#endif
+ IF (found(79,key_char//' timestep control',line,.FALSE.)) THEN
+ READ(79,*) i
+ IF (i/=0) THEN
+ READ(79,*,err=1001) thetaf, thetat, thetac, &
+ simtime(ismpl)
+ found_marker = .true.
+ ELSE
+ WRITE(*,'(A)') ' [R] : Steady state !'
+ END IF
+ ELSE
+ WRITE(*,'(A)') ' <D> : Steady state !'
+ END IF
+#ifndef noHDF
+ endif
+#endif
+ if (found_marker) then
+ found_marker = .false.
+ transient = .TRUE.
+ WRITE(*,'(A)') ' [R] : timestep control'
+ IF (thetaf<0.5D0) THEN
+ WRITE(*,'(A)') ' theta flow < .5, set to .5!'
+ thetaf = 0.5D0
+ END IF
+ IF (thetat<0.5D0) THEN
+ WRITE(*,'(A)') ' theta temp < .5, set to .5!'
+ thetat = 0.5D0
+ END IF
+ IF (thetac<0.5D0) THEN
+ WRITE(*,'(A)') ' theta conc < .5, set to .5!'
+ thetat = 0.5D0
+ END IF
+ END IF
+
+ ! Default time unit [s]
+ tunit = tunit_const
+#ifndef noHDF
+ if (h5parse_use_hdf5_datafile) then
+ if (h5parse_check_attr_exist("tunit","time")) then
+ call h5parse_read_double_attribute("tunit", tunit, "time")
+ found_marker = .true.
+ end if
+ else
+#endif
+ IF (found(79,key_char//' tunit',line,.FALSE.)) THEN
+ READ(79,*) tunit
+ found_marker = .true.
+ END IF
+#ifndef noHDF
+ end if
+#endif
+ if (found_marker) then
+ found_marker = .false.
+ WRITE(*,'(A,1e24.8)') ' [R] : tunit =', tunit
+ else
+ WRITE(*,'(A,1e24.8,A)') ' <D> : tunit =', tunit, ' !'
+ end if
+
+! simulation start time (overwrite the reading in section "# time")
+#ifndef noHDF
+ if (h5parse_use_hdf5_datafile) then
+ if (h5parse_check_attr_exist("tstart","time")) then
+ found_marker = .true.
+ ! tstart was already read before
+ end if
+ else
+#endif
+ IF (found(79,key_char//' tstart',line,.FALSE.)) THEN
+ READ(79,*) simtime(ismpl)
+ found_marker = .true.
+ END IF
+#ifndef noHDF
+ end if
+#endif
+ if (found_marker) then
+ found_marker = .false.
+ WRITE(*,'(A,1e24.8)') ' [R] : tstart =', simtime(ismpl)
+ else
+ WRITE(*,'(A,1e24.8)') ' <D> : tstart=', simtime(ismpl)
+ end if
+
+! offset of the simulation time index
+ itimestep_0 = 0
+#ifndef noHDF
+ if (h5parse_use_hdf5_datafile) then
+ if (h5parse_check_attr_exist("titer","time")) then
+ call h5parse_read_integer_attribute("titer", itimestep_0, "time")
+ found_marker = .true.
+ end if
+ else
+#endif
+ IF (found(79,key_char//' titer',line,.FALSE.)) THEN
+ READ(79,*) itimestep_0
+ found_marker = .true.
+ END IF
+#ifndef noHDF
+ end if
+#endif
+ if (found_marker) then
+ found_marker = .false.
+ WRITE(*,'(A,1I7)') ' [R] : titer =', itimestep_0
+ else
+ WRITE(*,'(A,1I7)') ' <D> : titer =', itimestep_0
+ end if
+
+! convert into sec.
+ simtime(ismpl) = simtime(ismpl)*tunit
+ simtime_0 = simtime(ismpl)
+
+! check for variable time step size
+#ifndef noHDF
+ if (h5parse_use_hdf5_datafile) then
+ if (h5parse_check_attr_exist("delt_start","time")) then
+ found_marker = .true.
+ call h5parse_read_double_attribute("delt_start", delt_start, "time")
+ call h5parse_read_double_attribute("delt_min", delt_min, "time")
+ call h5parse_read_double_attribute("delt_max", delt_max, "time")
+ call h5parse_read_double_attribute("max_simtime", max_simtime, "time")
+ call h5parse_read_integer_attribute("delt_double", delt_double, "time")
+ end if
+ else
+#endif
+ IF (found(79,key_char//' variable step size',line,.FALSE.)) THEN
+ READ(79,*) i
+ IF (i/=0) THEN
+ READ(79,*,err=1002) delt_start, delt_min, delt_max, max_simtime, delt_double
+ found_marker = .true.
+ END IF
+ END IF
+#ifndef noHDF
+ end if
+#endif
+ ! Set flag for variable step size
+ delt_vary = found_marker
+
+ if (found_marker) then
+ found_marker = .false.
+ WRITE(*,*)
+ WRITE(*,'(1A)') ' [R] : Variable time stepping: '
+ WRITE(*,'(1A,1e12.4)') ' Starting step size: ', delt_start
+ WRITE(*,'(1A,1e12.4)') ' Minimum step size: ', delt_min
+ WRITE(*,'(1A,1e12.4)') ' Maximum step size: ', delt_max
+ WRITE(*,'(1A,1e12.4)') ' Maximum simulation time: ', max_simtime
+ WRITE(*,'(1A,1I7)') ' Doubling time: ', delt_double
+ WRITE(*,*)
+ end if
+
+ ! Default number of time periods
+ nperiod = 0
+
+ ! Default total number of time steps
+ ntimestep = 0
+
+ ! Define time periods from input
+ IF (.not. delt_vary) THEN
+
+ max_simtime = simtime(ismpl)
+#ifndef noHDF
+ if (h5parse_use_hdf5_datafile) then
+ if (h5parse_check_dataset_exist("time/periods")) then
+ found_marker = .true.
+ nperiod = h5parse_read_dimension_size_for_dataset("time/periods")
+ allocate(iperiod(nperiod,2))
+ call h5parse_read_2d_double_dataset("time/periods", dperiod(:nperiod,:))
+ call h5parse_read_2d_integer_dataset("time/iperiods", iperiod(:nperiod,:2))
+ end if
+ else
+#endif
+ IF (found(79,key_char//' time periods',line,.FALSE.)) THEN
+ found_marker = .true.
+
+ ! Read number of time periods
+ CALL get_arg('records',line,i,j)
+ IF (i<1 .OR. j<i) THEN
+ READ(79,*) nperiod
+ ELSE
+ READ(line(i:j),*) nperiod
+ END IF
+
+ ! Test that number of periods is a positive integer
+ if (nperiod < 1) then
+ write(unit = *, fmt = *) "[E]: Number of time periods in ", &
+ "'# time periods' must be positive integer.\n", &
+ "Input was nperiod=", nperiod
+ stop
+ end if
+
+ allocate(iperiod(nperiod,2))
+ allocate(dperiod(nperiod,2))
+
+ ! Read time period information
+ DO k = 1, nperiod
+! ---------------
+ READ(79,'(1A)') line
+! step_type : 0=not set, 1=linear, 2=logarithmic
+ step_type = 0
+ i = locstr(line,'lin')
+ IF (i>=1) step_type = 1
+ i = locstr(line,'log')
+ IF (i>=1) step_type = 2
+! JK: Logarithm
+ i = locstr(line,'jlo')
+ IF (i>=1) step_type = 3
+! increase
+ i = locstr(line,'inc')
+ IF (i>=1) step_type = abs(step_type)
+! decrease
+ i = locstr(line,'dec')
+ IF (i>=1) step_type = -abs(step_type)
+
+ ! For time period k:
+ ! - Read 'dperiod': [ start of time period, end of time period ]
+ ! - Read 'iperiod': [ # time steps, time step type]
+ IF (step_type==0) THEN
+! need a third value as the time step type
+ READ(line,*,err=2001) dperiod(k,1), dperiod(k,2), &
+ (iperiod(k,j),j=1,2)
+ ELSE
+ READ(line,*,err=2002) dperiod(k,1), dperiod(k,2), &
+ (iperiod(k,j),j=1,1)
+ iperiod(k,2) = step_type
+ END IF
+ end do
+ end if
+#ifndef noHDF
+ end if
+#endif
+
+ if (found_marker) then
+ WRITE(*,'(A,I4)') ' [R] : periods, records=', nperiod
+ found_marker = .false.
+ DO k = 1, nperiod
+ ntimestep = ntimestep + iperiod(k,1)
+ dperiod(k,1) = dperiod(k,1)*tunit
+ dperiod(k,2) = dperiod(k,2)*tunit
+ max_simtime = max(max_simtime,dperiod(k,2))
+
+ IF (iperiod(k,2)==1) THEN
+ WRITE(*,'(1A,1e12.4,1A,1e12.4,1A,1I8,1A)') &
+ ' time :', dperiod(k,1)/tunit, ' - ', &
+ dperiod(k,2)/tunit, ', '//key_char//' ', iperiod(k,1), ', linear'
+ ELSE IF (iperiod(k,2)==2) THEN
+ WRITE(*,'(1A,1e12.4,1A,1e12.4,1A,1I8,1A)') &
+ ' time :', dperiod(k,1)/tunit, ' - ', &
+ dperiod(k,2)/tunit, ', '//key_char//' ', iperiod(k,1), &
+ ', logarithmic ascending'
+ ELSE IF (iperiod(k,2)==3) THEN
+ WRITE(*,'(1A,1e12.4,1A,1e12.4,1A,1I8,1A)') &
+ ' time :', dperiod(k,1)/tunit, ' - ', &
+ dperiod(k,2)/tunit, ', '//key_char//' ', iperiod(k,1), &
+ ', varied logarithmic ascending'
+ ELSE IF (iperiod(k,2)==-2) THEN
+ WRITE(*,'(1A,1e12.4,1A,1e12.4,1A,1I8,1A)') &
+ ' time :', dperiod(k,1)/tunit, ' - ', &
+ dperiod(k,2)/tunit, ', '//key_char//' ', iperiod(k,1), &
+ ', logarithmic descending'
+ ELSE
+ WRITE(*,'(1A,1I2,1A,1I2,1A)') &
+ 'error: wrong time step type ', iperiod(k,2), ' at ', &
+ k, ' !'
+ STOP
+ END IF
+
+ ! Sanity checks
+ ! -------------
+
+ ! start time < end time
+ if (dperiod(k,2) <= dperiod(k,1)) then
+ write(*,'(1A,1I3,1A)') &
+ 'error: time period START smaller then the END at ', &
+ k, ' !'
+ write(*,'(1A,1e12.4,1A,1e12.4,1A)') 't_start = ', &
+ dperiod(k,1)/tunit, ' > t_end = ', dperiod(k,2)/tunit, &
+ ' in "read_time.f" !'
+ stop
+ end if
+ ! no negative start / end times
+ if (dperiod(k,1) < 0.0d0 .or. dperiod(k,2) < 0.0d0) then
+ write(*,'(1A,1I4,1A)') &
+ 'error: no negative times allowed (period', k, &
+ ') in "read_time.f" !'
+ write(*,'(1A,1e12.4,1A,1e12.4,1A)') 't_start = ', &
+ dperiod(k,1)/tunit, ' < 0, or t_end', dperiod(k,2)/tunit, &
+ ' < 0 in "read_time.f" !'
+ stop
+ end if
+ ! end time = next start time
+ if (k>=2) then
+ if (1.0d0-dperiod(k-1,2)/dperiod(k,1) > 1.0d-14) then
+ write(*,'(1A,1I3,1A,1I3,1A)') &
+ 'error: time gap between period ', k - 1, ' and ', &
+ k, ' !'
+ stop
+ end if
+ if (1.0d0-dperiod(k,1)/dperiod(k-1,2) > 1.0d-14) then
+ write(*,'(1A,1I3,1A,1I3,1A)') &
+ 'error: time overlapping between period ', k - 1, &
+ ' and ', k, ' !'
+ stop
+ end if
+ ! first start time <= beginning of simulation
+ else if (dperiod(1,1)>simtime(ismpl)) then
+ write(*,'(2A)') 'error: first time period begins', &
+ ' later than the simulation start time !'
+ stop
+ end if
+ ! -------------
+
+ END DO
+
+ ! Check the number of time periods
+ if (ntimestep < 1) then
+ write(unit = *, fmt = *) "Error: number of time steps (ntimestep = ", &
+ ntimestep, ") should be larger than zero."
+ stop
+ end if
+
+ ! Compute time period table
+ CALL calc_deltatime(ismpl)
+
+ deallocate(iperiod)
+ deallocate(dperiod)
+
+ END IF
+
+ END IF
+
+! read bc time periods
+ bctp = .FALSE.
+ IF (found(79,key_char//' bc time periods',line,.FALSE.)) THEN
+ CALL get_arg('records',line,i,j)
+ IF (i<1 .OR. j<i) THEN
+ READ(79,*) l
+ ELSE
+ READ(line(i:j),*) l
+ END IF
+ bctp = .TRUE.
+! clean counter table
+ DO i = 1, nbctp
+ ibcperiod(i) = 0
+ END DO
+! "bcperiod": (period-index,value-type,TP-ID,sample)
+! - value-type: time, Alpha, Beta
+! "ibcperiod" - number of periods: (TP-ID)
+! "lbcperiod" - on/off switch: (period-index,TP-ID)
+ DO i = 1, l
+ READ(79,*,err=3000,end=3000) id, num
+! sanity check
+ IF (num>ngsmax) THEN
+ WRITE(*,'(1A,1I3,1A,1I5,1A)') 'error: number of periods in "bc time periods" to big (max. ', &
+ ngsmax, ', ID=', id, ') !'
+ STOP
+ END IF
+ IF (id>nbctp) THEN
+ WRITE(*,'(1A)') 'error: something goes wrong with BC-TP indexing (software bug)!'
+ STOP
+ END IF
+!
+ ibcperiod(id) = num
+ DO k = 1, num
+ READ(79,'(1A)',err=3001,end=3001) line
+ READ(line,*,err=3002,end=3002) (bcperiod(k,j,id,ismpl), &
+ j=1,3)
+ lbcperiod(k,id) = .TRUE.
+ j = locstr(line,'off')
+ IF (j>=1) lbcperiod(k,id) = .FALSE.
+ END DO
+ DO k = 1, num
+ bcperiod(k,1,id,ismpl) = tunit*bcperiod(k,1,id,ismpl)
+ IF (k>=2) THEN
+ IF (bcperiod(k,1,id,ismpl)<=bcperiod(k-1,1,id,ismpl)) &
+ THEN
+ WRITE(*,'(1A,1I2,1A,1I4,2A)') 'error: BC time period record=', i, &
+ ' and time changing=', k, ' has a smaller start time than before', &
+ ' (sorting needed)!'
+ STOP
+ END IF
+ END IF
+ END DO
+ END DO
+ WRITE(*,'(1A,1I4,1A,1I4,1A)') ' [R] : BC time periods, records=', l,' (max index =',nbctp,')'
+! sanity check, full check for time period table - usage
+ DO i = 1, nbc_data
+ j = ibc_data(i,cbc_bctp)
+ IF (j>nbctp) THEN
+ WRITE(*,'(5A,1I4,1A)') 'error: "',pv_name(ibc_data(i,cbc_pv)), ' ', &
+ bc_name(ibc_data(i,cbc_bt)),'" time period mismatch, use of a BCTP table index ', &
+ j,' in the declaration, but not defined under "time periods"!'
+ STOP
+ END IF
+ IF (j>0) THEN
+ IF (ibcperiod(j)<1) THEN
+ WRITE(*,'(5A,1I4,1A)') 'error: "',pv_name(ibc_data(i,cbc_pv)), ' ', &
+ bc_name(ibc_data(i,cbc_bt)),'" time period mismatch, use of a BCTP table index ', &
+ j,' in the declaration, but not defined under "time periods" or zero!'
+ STOP
+ END IF
+ END IF
+ END DO
+ END IF
+
+! monitoring time steps
+ nmon = 0
+ monitor = .FALSE.
+ out_orientation = 0
+ IF (found(79,key_char//' monitor',line,.FALSE.)) THEN
+ monitor = .TRUE.
+ CALL get_arg('records',line,i,j)
+ IF (i<1 .OR. j<i) THEN
+ WRITE(*,'(1A)') &
+ 'error: in section "monitor", records=<number> needed!'
+ STOP
+ ELSE
+ READ(line(i:j),*) nmon
+ END IF
+ i = locstr(line,'col')
+ IF (i>=1) THEN
+! column wise orientation
+ out_orientation = 0
+ END IF
+ i = locstr(line,'row')
+ IF (i>=1) THEN
+! row wise orientation
+ out_orientation = 1
+ END IF
+ i = locstr(line,'new')
+ IF (i>=1) THEN
+ CALL get_arg('new',line,i,j)
+ IF (i>=1 .AND. j>=i) THEN
+! sainty check
+ IF (line(i:i)=='p' .AND. out_orientation==1) THEN
+ WRITE(*,'(1A)') 'error: "new=position" defined, &
+ &but "row" not supported for it!'
+ STOP
+ END IF
+! "time" defined, time named files
+ IF (line(i:i)=='t') out_orientation = out_orientation + &
+ 2
+! "position" defined, position named files
+ IF (line(i:i)=='p') out_orientation = out_orientation + &
+ 4
+ ELSE
+! default: time files
+ out_orientation = out_orientation + 2
+ END IF
+ END IF
+ WRITE(*,'(A,I4,1A,1I2)') &
+ ' [R] : monitoring points, records=', nmon, &
+ ', data orientation=', out_orientation
+ READ(79,*,err=4001) ((imon(i,j),j=1,4),i=1,nmon)
+! sanity checks
+ DO i = 1, nmon
+ IF (imon(i,1)>i0 .OR. imon(i,1)<1 .OR. imon(i,2)>j0 .OR. &
+ imon(i,2)<1 .OR. imon(i,3)>k0 .OR. imon(i,3)<1) THEN
+ WRITE(*,'(1A,1I5,1A)') 'error: monitor point ', i, &
+ ' out of range !'
+ STOP
+ END IF
+ END DO
+ ELSE
+ WRITE(*,'(1A)') ' <D> : no monitoring points !'
+ END IF
+
+! output times
+ noutt = 0
+ IF (found(79,key_char//' output times',line,.FALSE.)) THEN
+ CALL get_arg('records',line,i,j)
+ IF (i<1 .OR. j<i) THEN
+ READ(79,*) noutt
+ ELSE
+ READ(line(i:j),*) noutt
+ END IF
+ DEALLOCATE(outt)
+ memory = memory - 1
+ ALLOCATE(outt(noutt+1))
+ memory = memory + noutt + 1
+ IF (noutt > 0) READ(79,*) (outt(i),i=1,noutt)
+ DO i = 1, noutt
+ outt(i) = outt(i)*tunit
+ END DO
+ outt(noutt+1) = max_simtime*2.D0 +1.0d0
+ WRITE(*,'(A,I4)') ' [R] : output times, records=', noutt
+ ELSE
+ outt(1) = max_simtime*2.D0 +1.0d0
+ WRITE(*,'(A)') ' <D> : no output times !'
+ END IF
+
+!aw?? endif
+! ------------------
+
+! finish HDF5 support, when available
+ CALL close_hdf5()
+
+! close project config file
+ CLOSE(79)
+
+ WRITE(*,*)
+ WRITE(*,*)
+
+ RETURN
+
+! error handler
+1001 WRITE(*,'(2A)') 'error: in section "timestep control",', &
+ ' awaiting [thetaf thetat thetac simtime] !'
+ STOP
+1002 WRITE(*,'(2A)') 'error: in section "variable step size",', &
+ ' awaiting [delt_start, delt_min, delt_max, max_simtime, delt_double] !'
+ STOP
+2001 WRITE(*,'(1A)') 'error: awaiting four values per line !'
+ STOP
+2002 WRITE(*,'(1A)') 'error: awaiting three values per line !'
+ STOP
+3000 WRITE(*,'(2A)') 'error: in section "bc time periods",', &
+ ' awaiting [tp-ID tp-number] !'
+ STOP
+3001 WRITE(*,'(1A,1I3,1A)') &
+ 'error: awaiting BC time period information at line ', k, &
+ '!'
+ STOP
+3002 WRITE(*,'(1A,1I3,1A)') 'error: awaiting three values for ', &
+ num, ' lines !'
+ STOP
+4001 WRITE(*,'(1A,1I3,1A)') 'error: awaiting four values for ', &
+ nmon, ' lines !'
+ STOP
+ END
diff --git a/forward/mathfuncs/alfa.f90 b/forward/mathfuncs/alfa.f90
new file mode 100644
index 0000000..ba83a6e
--- /dev/null
+++ b/forward/mathfuncs/alfa.f90
@@ -0,0 +1,48 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief truncated series expansion of cosh(x) for x < 0.1
+!> @param[in] x input value
+!> @return truncated function value
+ double precision FUNCTION alfa(x)
+ IMPLICIT NONE
+ DOUBLE PRECISION x
+! double precision x2, x3, x5, x7
+ alfa = 0.D0
+ IF (abs(x)>1.D-30) alfa = (x/tanh(x)-1.D0)/x
+
+! if (abs(x).lt.1.d-1) then
+! x2 = x*x
+! x3 = x2*x
+! x5 = x3*x2
+! x7 = x5*x2
+! alfa = x/3.d0 - x3/4.5d1 + 2.d0*x5/9.45d2 -
+! & x7/4.725d3
+! alfa = x*3.333333333333333d-01
+! & - x3*2.222222222222222d-02
+! & + x5*2.116402116402117d-03
+! & - x7*2.116402116402116e-04
+! else
+! alfa=(x/tanh(x) - 1.d0)/x
+! endif
+ RETURN
+ END
diff --git a/forward/mathfuncs/amean.f90 b/forward/mathfuncs/amean.f90
new file mode 100644
index 0000000..8b27c06
--- /dev/null
+++ b/forward/mathfuncs/amean.f90
@@ -0,0 +1,34 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculate the arithmetic mean between x1 and x2
+!> @param[in] x1 first value
+!> @param[in] x2 second value
+!> @return arithmetic mean
+ DOUBLE PRECISION FUNCTION amean(x1,x2)
+ IMPLICIT NONE
+ DOUBLE PRECISION x1, x2
+!
+ amean = 0.5D0*(x1+x2)
+!
+ RETURN
+ END
diff --git a/forward/mathfuncs/interpolate_lin.f90 b/forward/mathfuncs/interpolate_lin.f90
new file mode 100644
index 0000000..08706f8
--- /dev/null
+++ b/forward/mathfuncs/interpolate_lin.f90
@@ -0,0 +1,125 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief inter cell interpolation
+!> @param[in] I0 i-dimension
+!> @param[in] J0 j-dimension
+!> @param[in] K0 k-dimension
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] vals state variables (values)
+!> @param[in] px I0-direction interpolation position
+!> @param[in] py J0-direction interpolation position
+!> @param[in] pz K0-direction interpolation position
+!> @param[in] delx I0-direction cell dimensions (delta size)
+!> @param[in] dely J0-direction cell dimensions (delta size)
+!> @param[in] delz K0-direction cell dimensions (delta size)
+!> @param[in] delxa I0-direction absolute cell positions
+!> @param[in] delya J0-direction absolute cell positions
+!> @param[in] delza K0-direction absolute cell positions
+!> @return interpolated value
+ DOUBLE PRECISION FUNCTION interpolatelin(i0,j0,k0, i,j,k, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
+ IMPLICIT NONE
+! i,j,k cell index (first corner - 3D)
+ INTEGER i, j, k, i0, j0, k0
+! neighbours i,j,k cell index (second corner - 3D)
+ INTEGER ni, nj, nk
+! state variables (values)
+ DOUBLE PRECISION vals(i0,j0,k0)
+! x,y,z cell dimensions (delta size)
+ DOUBLE PRECISION delx(i0), dely(j0), delz(k0)
+! x,y,z absolute cell position
+ DOUBLE PRECISION delxa(i0), delya(j0), delza(k0)
+! x,y,z interpolation position
+ DOUBLE PRECISION px, py, pz
+!
+ DOUBLE PRECISION d_a0, d_b0, d_a1, d_b1, d_a2, d_b2
+ DOUBLE PRECISION lin_interpol
+ EXTERNAL lin_interpol
+ INTRINSIC min, max, abs
+
+! get neighbour i-index
+ ni = i+1
+ IF (px<delxa(i)) ni = i-1
+ ni = min(max(ni,1),i0)
+! get neighbour j-index
+ nj = j+1
+ IF (py<delya(j)) nj = j-1
+ nj = min(max(nj,1),j0)
+! get neighbour k-index
+ nk = k+1
+ IF (pz<delza(k)) nk = k-1
+ nk = min(max(nk,1),k0)
+!
+! x1
+ d_a0 = vals(i,j,k)
+! x2
+ d_b0 = vals(ni,j,k)
+! y1
+ d_a1 = lin_interpol(d_a0,d_b0,abs(delxa(i)-px),(delx(i)+delx(ni))*0.5d0)
+!
+! x1
+ d_a0 = vals(i,nj,k)
+! x2
+ d_b0 = vals(ni,nj,k)
+! y2
+ d_b1 = lin_interpol(d_a0,d_b0,abs(delxa(i)-px),(delx(i)+delx(ni))*0.5d0)
+!
+! z1
+ d_a2 = lin_interpol(d_a1,d_b1,abs(delya(j)-py),(dely(j)+dely(nj))*0.5d0)
+!
+! x1
+ d_a0 = vals(i,j,nk)
+! x2
+ d_b0 = vals(ni,j,nk)
+! y1
+ d_a1 = lin_interpol(d_a0,d_b0,abs(delxa(i)-px),(delx(i)+delx(ni))*0.5d0)
+!
+! x1
+ d_a0 = vals(i,nj,nk)
+! x2
+ d_b0 = vals(ni,nj,nk)
+! y2
+ d_b1 = lin_interpol(d_a0,d_b0,abs(delxa(i)-px),(delx(i)+delx(ni))*0.5d0)
+!
+! z2
+ d_b2 = lin_interpol(d_a1,d_b1,abs(delya(j)-py),(dely(j)+dely(nj))*0.5d0)
+!
+ interpolatelin = lin_interpol(d_a2,d_b2,abs(delza(k)-pz),(delz(k)+delz(nk))*0.5d0)
+!
+ RETURN
+ END
+
+!> @brief linear interpolation
+!> @param[in] da value A
+!> @param[in] db value B
+!> @param[in] dp relative position
+!> @param[in] dd (delta) cell size
+!> @return linear interpolated value
+ DOUBLE PRECISION FUNCTION lin_interpol(da, db, dp, dd)
+ IMPLICIT NONE
+! da: value A; db: value B; dp: relative position; dd: (delta) cell size
+ DOUBLE PRECISION da, db, dp, dd
+ lin_interpol = (da*(dd-dp) + db*dp)/dd
+ RETURN
+ END
diff --git a/forward/mathfuncs/interpolate_pol.f90 b/forward/mathfuncs/interpolate_pol.f90
new file mode 100644
index 0000000..e8a7221
--- /dev/null
+++ b/forward/mathfuncs/interpolate_pol.f90
@@ -0,0 +1,290 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief inter cell interpolation
+!> @param[in] I0 i-dimension
+!> @param[in] J0 j-dimension
+!> @param[in] K0 k-dimension
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] vals state variables (values)
+!> @param[in] px I0-direction interpolation position
+!> @param[in] py J0-direction interpolation position
+!> @param[in] pz K0-direction interpolation position
+!> @param[in] delx I0-direction cell dimensions (delta size)
+!> @param[in] dely J0-direction cell dimensions (delta size)
+!> @param[in] delz K0-direction cell dimensions (delta size)
+!> @param[in] delxa I0-direction absolute cell position
+!> @param[in] delya J0-direction absolute cell position
+!> @param[in] delza K0-direction absolute cell position
+!> @return interpolated value
+ DOUBLE PRECISION FUNCTION interpolatepol(i0,j0,k0, i,j,k, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
+ IMPLICIT NONE
+! i,j,k cell index (first corner - 3D)
+ INTEGER i, j, k, i0, j0, k0, mode3d
+! corrected i,j,k, can be eliminated later - px,py,pz is inside the [i,j,k] cell ([0,0,0] corner)
+ INTEGER c_i, c_j, c_k
+! state variables (values)
+ DOUBLE PRECISION vals(i0,j0,k0)
+! x,y,z cell dimensions (delta size)
+ DOUBLE PRECISION delx(i0), dely(j0), delz(k0)
+! x,y,z absolute cell position
+ DOUBLE PRECISION delxa(i0), delya(j0), delza(k0)
+! x,y,z interpolation position
+ DOUBLE PRECISION px, py, pz
+!
+ DOUBLE PRECISION interpolate_3d, interpolate_am
+ EXTERNAL interpolate_3d, interpolate_am
+ INTRINSIC max, min
+
+! correct i-index
+ c_i = i
+ IF (px<delxa(i)) c_i = i-1
+ IF (px>delxa(min(i+1,i0))) c_i = i+1
+ c_i = min(max(c_i,1),i0)
+! correct j-index
+ c_j = j
+ IF (py<delya(j)) c_j = j-1
+ IF (py>delya(min(j+1,j0))) c_j = j+1
+ c_j = min(max(c_j,1),j0)
+! correct k-index
+ c_k = k
+ IF (pz<delza(k)) c_k = k-1
+ IF (pz>delza(min(k+1,k0))) c_k = k+1
+ c_k = min(max(c_k,1),k0)
+!
+ mode3d = 3
+ interpolatepol = interpolate_3d(i0,j0,k0, c_i,c_j,c_k, mode3d, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
+!
+ RETURN
+ END
+
+!> @brief inter cell interpolation (piece wise ???-methode), mode version
+!> @param[in] I0 i-dimension
+!> @param[in] J0 j-dimension
+!> @param[in] K0 k-dimension
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] mode3d direction mode, 1==I0, 2==J0, 3==K0
+!> @param[in] vals state variables (values)
+!> @param[in] px I0-direction interpolation position
+!> @param[in] py J0-direction interpolation position
+!> @param[in] pz K0-direction interpolation position
+!> @param[in] delx I0-direction cell dimensions (delta size)
+!> @param[in] dely J0-direction cell dimensions (delta size)
+!> @param[in] delz K0-direction cell dimensions (delta size)
+!> @param[in] delxa I0-direction absolute cell position
+!> @param[in] delya J0-direction absolute cell position
+!> @param[in] delza K0-direction absolute cell position
+!> @return piece wise ???-methode interpolated value
+ DOUBLE PRECISION RECURSIVE FUNCTION interpolate_3d(i0,j0,k0, i,j,k, mode3d, vals, px,py,pz, &
+ delx,dely,delz, delxa,delya,delza)
+ IMPLICIT NONE
+! i,j,k cell index (first corner - 3D)
+ INTEGER i, j, k, i0, j0, k0, mode3d
+! state variables (values)
+ DOUBLE PRECISION vals(i0,j0,k0)
+! x,y,z cell dimensions (delta size)
+ DOUBLE PRECISION delx(i0), dely(j0), delz(k0)
+! x,y,z absolute cell position
+ DOUBLE PRECISION delxa(i0), delya(j0), delza(k0)
+! x,y,z interpolation position
+ DOUBLE PRECISION px, py, pz
+!
+ DOUBLE PRECISION d_a2, d_a3, d_a4, d_a5, d_d23, d_d34, d_d45, dp
+ DOUBLE PRECISION pw_uk_interpol, pw_cr_interpol, interpolate_3d_wrapper, lin_interpol
+ EXTERNAL pw_uk_interpol, pw_cr_interpol, interpolate_3d_wrapper, lin_interpol
+ INTRINSIC min, max
+
+ IF (mode3d==0) THEN
+ interpolate_3d = vals(i,j,k)
+ RETURN
+ END IF
+ IF (mode3d==1) THEN
+! prepare X-direction interpolation, compute directly
+! cell size deltas
+ d_d23 = (delx(max(i-1,1))+delx(i))*0.5d0
+ d_d34 = (delx(i)+delx(min(i+1,I0)))*0.5d0
+ d_d45 = (delx(min(i+1,I0))+delx(min(i+2,I0)))*0.5d0
+! (x) delta
+ dp = px -delxa(i)
+! function values
+ d_a2 = interpolate_3d_wrapper(i0,j0,k0, max(i-1,1),j,k, mode3d-1, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
+ d_a3 = interpolate_3d_wrapper(i0,j0,k0, i,j,k, mode3d-1, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
+ d_a4 = interpolate_3d_wrapper(i0,j0,k0, min(i+1,I0),j,k, mode3d-1, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
+ d_a5 = interpolate_3d_wrapper(i0,j0,k0, min(i+2,I0),j,k, mode3d-1, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
+! sanity check
+ IF (px<delxa(i).OR.(px>delxa(min(i+1,I0)).AND.i<I0)) THEN
+ WRITE(*,'(1a,1i7,1a,1g16.8)') 'error: i-cell index (',i, &
+ ') incorrect for position :',px
+ STOP
+ END IF
+ END IF
+ IF (mode3d==2) THEN
+! prepare Y-direction interpolation, consist of X-direction interpolations
+! cell size deltas
+ d_d23 = (dely(max(j-1,1))+dely(j))*0.5d0
+ d_d34 = (dely(j)+dely(min(j+1,J0)))*0.5d0
+ d_d45 = (dely(min(j+1,J0))+dely(min(j+2,J0)))*0.5d0
+! (y) delta
+ dp = py -delya(j)
+! function values
+ d_a2 = interpolate_3d_wrapper(i0,j0,k0, i,max(j-1,1),k, mode3d-1, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
+ d_a3 = interpolate_3d_wrapper(i0,j0,k0, i,j,k, mode3d-1, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
+ d_a4 = interpolate_3d_wrapper(i0,j0,k0, i,min(j+1,J0),k, mode3d-1, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
+ d_a5 = interpolate_3d_wrapper(i0,j0,k0, i,min(j+2,J0),k, mode3d-1, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
+! sanity check
+ IF (py<delya(j).OR.(py>delya(min(j+1,J0)).AND.j<J0)) THEN
+ WRITE(*,'(1a,1i7,1a,1g16.8)') 'error: j-cell index (',j, &
+ ') incorrect for position :',py
+ STOP
+ END IF
+ END IF
+ IF (mode3d==3) THEN
+! prepare Z-direction interpolation, consist of Y-direction interpolations
+! cell size deltas
+ d_d23 = (delz(max(k-1,1))+delz(k))*0.5d0
+ d_d34 = (delz(k)+delz(min(k+1,K0)))*0.5d0
+ d_d45 = (delz(min(k+1,K0))+delz(min(k+2,K0)))*0.5d0
+! (z) delta
+ dp = pz -delza(k)
+! function values
+ d_a2 = interpolate_3d_wrapper(i0,j0,k0, i,j,max(k-1,1), mode3d-1, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
+ d_a3 = interpolate_3d_wrapper(i0,j0,k0, i,j,k, mode3d-1, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
+ d_a4 = interpolate_3d_wrapper(i0,j0,k0, i,j,min(k+1,K0), mode3d-1, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
+ d_a5 = interpolate_3d_wrapper(i0,j0,k0, i,j,min(k+2,K0), mode3d-1, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
+! sanity check
+ IF (pz<delza(k).OR.(pz>delza(min(k+1,K0)).AND.k<K0)) THEN
+ WRITE(*,'(1a,1i7,1a,1g16.8)') 'error: k-cell index (',k, &
+ ') incorrect for position :',pz
+ STOP
+ END IF
+ END IF
+!
+! compute unknown-methode interpolation
+ interpolate_3d = pw_uk_interpol(d_a2, d_a3, d_a4, d_a5, dp, d_d23, d_d34, d_d45)
+!.UNUSED/ compute Catmull-Rom interpolation
+! interpolate_3d = pw_cr_interpol(d_a2, d_a3, d_a4, d_a5, dp, d_d23, d_d34, d_d45)
+!.UNUSED/ compute linear interpolation
+! interpolate_3d = lin_interpol(d_a3, d_a4, dp, d_d34)
+!
+ RETURN
+ END
+
+!> @brief wrapper routine for the inter cell interpolation (piece wise ???-methode), mode version
+!> @param[in] I0 i-dimension
+!> @param[in] J0 j-dimension
+!> @param[in] K0 k-dimension
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] mode3d direction mode, 1==I0, 2==J0, 3==K0
+!> @param[in] vals state variables (values)
+!> @param[in] px I0-direction interpolation position
+!> @param[in] py J0-direction interpolation position
+!> @param[in] pz K0-direction interpolation position
+!> @param[in] delx I0-direction cell dimensions (delta size)
+!> @param[in] dely J0-direction cell dimensions (delta size)
+!> @param[in] delz K0-direction cell dimensions (delta size)
+!> @param[in] delxa I0-direction absolute cell position
+!> @param[in] delya J0-direction absolute cell position
+!> @param[in] delza K0-direction absolute cell position
+!> @return piece wise ???-methode interpolated value
+ DOUBLE PRECISION RECURSIVE FUNCTION interpolate_3d_wrapper(i0,j0,k0, i,j,k, mode3d, vals, px,py,pz, &
+ delx,dely,delz, delxa,delya,delza)
+ IMPLICIT NONE
+! i,j,k cell index (first corner - 3D)
+ INTEGER i, j, k, i0, j0, k0, mode3d
+! state variables (values)
+ DOUBLE PRECISION vals(i0,j0,k0)
+! x,y,z cell dimensions (delta size)
+ DOUBLE PRECISION delx(i0), dely(j0), delz(k0)
+! x,y,z absolute cell position
+ DOUBLE PRECISION delxa(i0), delya(j0), delza(k0)
+! x,y,z interpolation position
+ DOUBLE PRECISION px, py, pz
+!
+ DOUBLE PRECISION interpolate_3d
+ EXTERNAL interpolate_3d
+ interpolate_3d_wrapper = interpolate_3d(i0,j0,k0, i,j,k, mode3d, vals, px,py,pz, delx,dely,delz, delxa,delya,delza)
+ RETURN
+ END
+
+!> @brief piece wise unknown-methode interpolation
+!> @param[in] f_am value x_a-1
+!> @param[in] f_a value x_a
+!> @param[in] f_b value x_b
+!> @param[in] f_bp value x_b+1
+!> @param[in] dp relative position >= 0, for [x_a x_b] intervall, difference from x_a
+!> @param[in] d_aam (delta) cell size, for [x_a-1 x_a] interval
+!> @param[in] d_ba (delta) cell size, for [x_a x_b] interval
+!> @param[in] d_bpb (delta) cell size, for [x_b x_b+1] interval
+!> @return interpolated value
+ DOUBLE PRECISION FUNCTION pw_uk_interpol(f_am, f_a, f_b, f_bp, dp, d_aam, d_ba, d_bpb)
+ IMPLICIT NONE
+! f_* function values for all nodes
+! dp: relative position >= 0
+! d_* (delta) cell size, for all x_* intervals
+ DOUBLE PRECISION f_am, f_a, f_b, f_bp, dp, d_aam, d_ba, d_bpb
+ DOUBLE PRECISION ds, gf_sm, gf_xm, gf_am, gf_bm, i_s, gf_s
+ DOUBLE PRECISION gf_b_a
+ INTRINSIC max, min, dabs
+ LOGICAL test_null
+ EXTERNAL test_null
+
+! g_s = (2.0d0*f_b -2.0d0*f_a -gf_am*(ds-a) -gf_bm*(b-ds))/(b-a)
+! ds = (g_s*(b-a) -2.0d0*f_b +2.0d0*f_a -gf_am*a +gf_bm*b) /(gf_bm -gf_am)
+! mit a:=0, b:=d_ba ->
+! g_s = (f_b+f_b -f_a-f_a -gf_am*ds -gf_bm*(d_ba-ds))/d_ba
+! ds = (g_s*d_ba -f_b-f_b +f_a+f_a +gf_bm*d_ba) /(gf_bm -gf_am)
+
+! mean gradient between [a b]
+ gf_s = (f_b -f_a) /d_ba
+! gradient mean for (a)
+ gf_am = 0.5d0 *((f_a -f_am) /d_aam +gf_s)
+! gradient mean for (b)
+ gf_bm = 0.5d0 *(gf_s +(f_bp -f_b) /d_bpb)
+!
+ gf_b_a = gf_bm -gf_am
+! delta (x) sattle point
+ ds = 0.5d0*d_ba
+! gradient for the sattle point (s)
+ gf_sm = 2.0d0*gf_s -0.5d0 *(gf_am +gf_bm)
+!
+ IF (dp<ds) THEN
+! gradient for (x)
+ gf_xm = gf_am +dp *(gf_sm -gf_am) /ds
+! f_x, result for (x)
+ pw_uk_interpol = f_a +(gf_am +gf_xm) *dp *0.5d0
+ ELSE
+! integral area [a s]
+ i_s = (gf_sm +gf_am) *ds *0.5d0
+! gradient for (x)
+ gf_xm = gf_sm +(dp -ds) *(gf_bm -gf_sm) /(d_ba -ds)
+! f_x, result for (x)
+ pw_uk_interpol = f_a +(gf_sm +gf_xm) *(dp -ds) *0.5d0 +i_s
+ ENDIF
+!
+ RETURN
+ END
diff --git a/forward/mathfuncs/mean3d.f90 b/forward/mathfuncs/mean3d.f90
new file mode 100644
index 0000000..3543723
--- /dev/null
+++ b/forward/mathfuncs/mean3d.f90
@@ -0,0 +1,51 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculate the mean of a 3D array
+!> @param[in] values 3D array
+!> @param[out] meanv average value
+!> @param[in] ismpl local sample index (ignored here)
+ SUBROUTINE mean3d(values,meanv,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_linfos
+ IMPLICIT NONE
+ DOUBLE PRECISION meanv, values(i0,j0,k0)
+ integer :: i, j, k
+ integer :: ismpl
+ INTRINSIC dble
+
+ IF (linfos(3)>=2) WRITE(*,*) ' ... mean 3D working'
+!
+ meanv = 0.0d0
+ DO k = 1, K0
+ DO j = 1, J0
+ DO i = 1, I0
+ meanv = meanv + values(i,j,k)
+ END DO
+ END DO
+ END DO
+!
+ meanv = meanv/dble(i0*j0*k0)
+!
+ RETURN
+ END
diff --git a/forward/mod_conc.f90 b/forward/mod_conc.f90
new file mode 100644
index 0000000..9c06f15
--- /dev/null
+++ b/forward/mod_conc.f90
@@ -0,0 +1,56 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief global variables for transport
+module mod_conc
+
+ !> @brief Number of tracers.
+ !> @details
+ !> Number of tracers. \n
+ !>
+ !> Read under `# ntrans`, first entry.
+ integer :: ntrac
+
+ !> @brief Number of reactive components.
+ !> @details
+ !> Number of reactive components. \n
+ !>
+ !> Read under `# ntrans`, second entry.
+ integer :: nchem
+
+ !> @brief Number of transport species.
+ !> @details
+ !> Number of transport species. \n
+ !> Sum of number of tracers and number of reactive components. \n
+ !>
+ !> Read under `# ntrans`, first entry.
+ integer :: ntrans
+
+! linear solver
+ double precision errc,aparc,nlmaxc
+ integer controlc,lmaxitc
+!
+! stopping criteria nonlinear outer loop
+ double precision nltolc,nlrelaxc
+ double precision mmas_nacl
+ parameter (mmas_nacl = 58.443d0)
+end module mod_conc
diff --git a/forward/mod_data.f90 b/forward/mod_data.f90
new file mode 100644
index 0000000..2a530b0
--- /dev/null
+++ b/forward/mod_data.f90
@@ -0,0 +1,35 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief global variables for the specification of the data
+module mod_data
+
+ !> @brief Total number of data entries.
+ !> @details
+ !> Total number of data entries. \n
+ !> Computed from records values of `# data` inputs.
+ integer :: ndata
+
+! temp., head., conc., pres., ???, sat_n
+ integer ndata_t,ndata_h,ndata_c,ndata_p,ndata_b,ndata_s
+
+end module mod_data
diff --git a/forward/mod_flow.f90 b/forward/mod_flow.f90
new file mode 100644
index 0000000..eb0cc61
--- /dev/null
+++ b/forward/mod_flow.f90
@@ -0,0 +1,102 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief global variables for flow arrays
+module mod_flow
+
+ ! Flow: linear solver parameters
+ ! ------------------------------
+
+ !> @brief Flow linear solver error input.
+ !> @details
+ !> Flow linear solver error input. \n
+ !> Read under `# lsolvef`, first entry. \n\n
+ !> User in linear solver routines for break criteria.
+ double precision :: errf
+
+ !> @brief Flow linear solver explicit/implicit switch.
+ !> @details
+ !> Flow linear solver explicit/implicit switch. \n
+ !> Currently set to default 1.0d0. \n\n
+ !> Switching capability currently disabled.
+ double precision :: aparf
+
+ !> @brief Flow linear solver specification number.
+ !> @details
+ !> Flow linear solver specification number. \n
+ !> Read under `# lsolvef`, second entry. \n\n
+ !> Used in solve.f90 to specify solvername, solve criterion,
+ !> preconditioner. \n\n
+ !>
+ !> [ ctrl = solvername + 16*criteria + 256*precondition ] \n
+ !> extract [ ctrl ] : \n
+ !> solvername = mod(ctrl,16) \n
+ !> ctrl = ctrl/16 \n
+ !> criteria = mod(ctrl,16) \n
+ !> ctrl = ctrl/16 \n
+ !> precondition = ctrl \n\n
+ !>
+ !> Examples:\n
+ !> - 64: BiCGStab (parallel) solver, autodetected error, ILU
+ !> preconditioner
+ !> - 67: PLU (serial) solver, autodetected error, ILU
+ !> preconditioner
+ integer :: controlf
+
+ !> @brief Flow linear solver maximum iteration number.
+ !> @details
+ !> Flow linear solver maximum iteration number. \n
+ !> Read under `# lsolvef`, third entry. \n\n
+ integer :: lmaxitf
+!
+ ! stopping criteria nonlinear outer loop, head or pressure
+ ! --------------------------------------------------------
+
+ !> @brief Flow nonlinear iteration tolerance.
+ !> @details
+ !> Flow nonlinear iteration tolerance. \n
+ !> If the maximal difference between headold and head is smaller
+ !> than this tolerance, the iteration converged.
+ double precision :: nltolf
+
+ !> @brief Flow nonlinear iteration relaxation.
+ !> @details
+ !> Flow nonlinear iteration relaxation. \n
+ double precision :: nlrelaxf
+
+ !> @brief Flow nonlinear iteration max.
+ !> @details
+ !> Flow nonlinear iteration max. \n
+ !> Used in relaxation, `nl_relax`.
+ double precision :: nlmaxf
+
+! stopping criteria nonlinear outer loop, saturation
+ double precision nltols,nlrelaxs,nlmaxs
+! constant of gravitational force, compressibility of rock
+ double precision grav,rref
+!
+! Input and Output are in [MPa], internal computation in [Pa]
+ double precision Pa_conv, Pa_conv1
+ parameter (Pa_conv = 1.0d6)
+ parameter (Pa_conv1 = 1.0d0 / Pa_conv)
+!
+end module mod_flow
diff --git a/forward/mod_genrl.f90 b/forward/mod_genrl.f90
new file mode 100644
index 0000000..29b9954
--- /dev/null
+++ b/forward/mod_genrl.f90
@@ -0,0 +1,253 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief commonly used global variables and constants
+module mod_genrl
+
+ !> @brief Memory of data in 8Bytes (std. double precision size).
+ !> @details
+ !> Memory of data in 8Bytes (std. double precision size). \n
+ double precision memory
+
+! file output compression tool
+ integer compress_out
+
+ !> @brief Number of cells in x-direction.
+ !> @details
+ !> Number of cells in x-direction. \n
+ !> Read in under `# grid`, first entry.
+ integer :: i0
+
+ !> @brief Number of cells in y-direction.
+ !> @details
+ !> Number of cells in y-direction. \n
+ !> Read in under `# grid`, second entry.
+ integer :: j0
+
+ !> @brief Number of cells in z-direction.
+ !> @details
+ !> Number of cells in z-direction. \n
+ !> Read in under `# grid`, third entry.
+ integer :: k0
+
+ !> @brief Output orientation of monitoring output.
+ !> @details
+ !> Output orientation of monitoring output. \n \n
+ !> `out_orientation` values: \n
+ !> 0: normal (pv column wise), each time step has its own block
+ !> (mp row wise) \n
+ !> 1: transposed (pv row wise), each time step has its own
+ !> block (mp column wise) \n
+ !> 2: normal (pv column wise), new file for each time step (mp
+ !> row wise) \n
+ !> 3: transposed (pv row wise), new file for each time step
+ !> (mp column wise) \n
+ !> 4: normal (pv column wise), new file for each monitor point
+ !> (time row wise) \n
+ integer :: out_orientation
+
+ !> @brief Runmode integer.
+ !> @details
+ !> Runmode integer. \n
+ !> Read in under `# runmode`. \n\n
+ !>
+ !> 0: forward modeling \n
+ !> 1: forward modeling and data fit \n
+ !> 2: inverse modeling or extra steady state \n
+ !> 3: inverse modeling \n
+ integer :: runmode
+
+ !> @brief Maximum number of nonlinear iterations.
+ !> @details
+ !> Maximum number of nonlinear iterations. \n
+ !> Important for the Picard iterations.\n\n
+ !>
+ !> Read under `# nlsolve`, first entry.
+ integer :: maxiter_nl
+
+ integer nladapt
+
+ !> @brief Switch for checking non-linear iteration convergence.
+ !> @details
+ !> Switch for checking non-linear iteration convergence. \n
+ !> - 0: check convergence (default).\n
+ !> - other: do not check convergence.\n
+ !>
+ !> Read under `# nlsolve`, second line, only entry.
+ integer nlconverge
+!
+ logical head_active, temp_active
+ logical trac_active,chem_active,trans_active, pres_active
+ logical vtk_out,tec_out,hdf_out,txt_out
+
+ !> @brief Switch informing if an initial flow transformation is needed.
+ !> @details
+ !> Switch informing if an initial flow transformation is needed. \n
+ !> This variable is .false. if the not-computed flow-variable
+ !> (f.e. pres in head-based computation) is given in the input
+ !> file. Otherwise `head2pres` or `pres2head` will be called
+ !> inside /forward/forward_init.f90.
+ logical is_init_flow_trafo_needed
+
+ !> @brief Switch for disabling multiple outputs.
+ !> @details
+ !> Switch for disabling multiple outputs. \n
+ !> Disables output in write_logs, write_data, write_outt,
+ !> write_tecdiff, write_monitor.
+ logical write_disable
+ logical write_smonitor, write_param
+
+ !> @brief Switch for disabling iteration output.
+ !> @details
+ !> Switch for disabling iteration output. \n
+ !> Disables output from forward iteration.
+ logical write_iter_disable
+
+ !> @brief Switch for reading external input files.
+ !> @details
+ !> Switch for reading external input files. \n
+ !> If and only if read_external_input is .true., the input file
+ !> is searched for external input files names in the subroutine
+ !> read_control.
+ logical read_external_input
+
+ !> @brief Hashtag character.
+ !> @details
+ !> Hashtag character. \n
+ !> Used as input keyword signifier.
+ character (len=1), parameter :: key_char = '#'
+
+ !> @brief Number of samples.
+ !> @details
+ !> Number of samples. \n
+ !> For example, the number of samples in a Monte Carlo
+ !> simulation. Also used in OpenMP parallelization.
+ integer nsmpl
+
+ ! Useful constants
+ ! ----------------
+
+ !> @brief Very big number.
+ !> @details
+ !> Very big number. \n\n
+ double precision, parameter :: big = 1.0d30
+
+ !> @brief Very small number.
+ !> @details
+ !> Very small number. \n\n
+ double precision, parameter :: small = 1.0d-300
+
+ !> @brief Circle number pi.
+ !> @details
+ !> Circle number pi. \n\n
+ double precision, parameter :: pi = 3.141592653589793d0
+
+ !> @brief Flag for log permeability output.
+ !> @details
+ !> Flag for log permeability output. \n\n
+ logical, parameter :: klogflag = .true.
+
+ !> @brief Number of possible old saved arrays.
+ !> @details
+ !> Number of possible old saved arrays. \n\n
+ !>
+ !> max number of "cgen_*"
+ integer, parameter :: ncgen = 2
+
+ !> @brief Index constant for old saved arrays.
+ !> @details
+ !> Index constant for old saved arrays. \n\n
+ !>
+ !> index constants for HEAD, TEMP and PRES
+ !> forward iteration [x_i-1,j];
+ !> do not change it without a change of any
+ !> "headold" into "headold(1,cgen_fw)" ccc
+ integer, parameter :: cgen_fw = 1
+
+ !> @brief Index constant for old saved arrays.
+ !> @details
+ !> Index constant for old saved arrays. \n\n
+ !>
+ !> Used around nonlinear forward iteration in `forward_iter`.
+ !>
+ !> index constants for HEAD, TEMP and PRES
+ !> forward iteration [x_i-1,j];
+ !> do not change it without a change of any
+ !> "headold" into "headold(1,cgen_fw)" ccc\n\n
+ !>
+ !> time iteration
+ integer, parameter :: cgen_time = 2
+
+ ! index of the <master> sample
+ integer, parameter :: idx_master=1
+
+ !> @brief Doubling threshold for variable time step size
+ !> @details
+ !> Doubling threshold for variable time step size. \n\n
+ !>
+ !> Once delt_count reaches delt_double, the time step size is
+ !> doubled. \n\n
+ !>
+ !> Convergence flag, doubling value for variable time step
+ !> size
+ integer delt_double
+
+ !> @brief Variable step size nonlinear iteration counter.
+ !> @details
+ !> Variable step size nonlinear iteration counter. \n\n
+ !>
+ !> This is a helper-counter that together with the current
+ !> number of iterations (in `forward_picard`) decides whether
+ !> the doubling counter of the variable time step size utitily
+ !> should be moved towards or away from doubling the time step
+ !> size.
+ integer :: iter_nlold
+
+ !> @brief Flag for Variable step size
+ !> @details
+ !> Flag for Variable step size. \n\n
+ !>
+ !> True if variable step size is used.
+ logical :: delt_vary
+
+ !> @brief Initial time step size for variable step size
+ !> @details
+ !> Initial time step size for variable step size. \n\n
+ !>
+ !> First input under `# variable step size`.
+ double precision :: delt_start
+
+ !> @brief Minimum time step size for variable step size
+ !> @details
+ !> Minimum time step size for variable step size. \n\n
+ !>
+ !> Second input under `# variable step size`.
+ double precision :: delt_min
+
+ !> @brief Maximum time step size for variable step size
+ !> @details
+ !> Maximum time step size for variable step size. \n\n
+ !>
+ !> Third input under `# variable step size`.
+ double precision :: delt_max
+
+end module mod_genrl
diff --git a/forward/mod_genrlc.f90 b/forward/mod_genrlc.f90
new file mode 100644
index 0000000..7d17dc5
--- /dev/null
+++ b/forward/mod_genrlc.f90
@@ -0,0 +1,38 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief commonly used character global variables
+module mod_genrlc
+ character (len=80) :: title
+ character (len=256) :: project
+
+ !> @brief Filename of status log output file.
+ !> @details
+ !> Filename of status log output file. \n
+ character (len=256) :: status_log
+!
+! defines the PROPS and USER choice
+ character (len=80) :: def_props, def_user
+!
+! external file control for: data
+ character (len=256) :: filename_data
+end module mod_genrlc
diff --git a/forward/mod_linfos.f90 b/forward/mod_linfos.f90
new file mode 100644
index 0000000..bdac57b
--- /dev/null
+++ b/forward/mod_linfos.f90
@@ -0,0 +1,53 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief info, verbosity level
+module mod_linfos
+
+ !> @brief Array of verbosity level switches.
+ !> @details
+ !> Array of verbosity level switches. \n\n
+ !> linfos(1)=\n
+ !> - `0`, only necessary outputs\n
+ !> - `1`, time steps information\n
+ !> - `2`, with initialisation and file reading outputs\n
+ !>
+ !> linfos(2)=\n
+ !> - `0`, 'inversion/simulation' with only necessary outputs\n
+ !> - `1`, 'inversion/simulation' with some more outputs\n
+ !> - `2`, 'inversion/simulation' with all outputs (optimisation outputs)\n
+ !> - `3`, 'inversion/simulation' with all debug outputs\n
+ !>
+ !> linfos(3)=\n
+ !> - `-1`, 'non linear solver' disables some error outputs\n
+ !> - `0`, 'non linear solver' with only necessary outputs\n
+ !> - `1`, 'non linear solver' with some stage outputs\n
+ !> - `2`, 'non linear solver' with all outputs\n
+ !>
+ !> linfos(4)=\n
+ !> - `0`, 'system solver' without any outputs\n
+ !> - `1`, 'system solver' with some outputs\n
+ !> - `2`, 'system solver' with some debug outputs\n
+ !> - `3`, 'system solver' with all debug outputs\n
+ integer, dimension (4) :: linfos
+
+end module mod_linfos
diff --git a/forward/mod_temp.f90 b/forward/mod_temp.f90
new file mode 100644
index 0000000..26236c3
--- /dev/null
+++ b/forward/mod_temp.f90
@@ -0,0 +1,34 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief global variables for heat transport
+module mod_temp
+! linear solver
+ integer controlt,lmaxitt
+ double precision errt,apart
+!
+! stopping criteria nonlinear outer loop
+ double precision nltolt,nlrelaxt,nlmaxt
+!
+! rock heat capacity, density ,conductivity
+ double precision cma1,cma2,cma3,rhom,tref,hpf
+end module mod_temp
diff --git a/forward/mod_time.f90 b/forward/mod_time.f90
new file mode 100644
index 0000000..81dbcd3
--- /dev/null
+++ b/forward/mod_time.f90
@@ -0,0 +1,172 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief global variables for timestepping
+module mod_time
+
+ !> @brief Time unit factor.
+ !> @details
+ !> Time unit factor. \n
+ !> Default: 1.0d0. \n\n
+ !>
+ !> Read in under keyword `# tunit`. \n\n
+ !>
+ !> All time inputs are multiplied by this factor. Since the
+ !> general computation expects seconds, the following
+ !> correspondences hold: \n
+ !> - tunit = 1.0d0: unit [s] \n
+ !> - tunit = 60.0d0: unit [min] \n
+ !> - tunit = 3600.0d0: unit [h] \n
+ !> - tunit = 86400.0d0: unit [day] \n
+ !> - tunit = 31536000.0d0: unit [a] with 365 days per year \n
+ double precision :: tunit
+
+ !> @brief Default time unit factor.
+ !> @details
+ !> Default time unit factor. \n
+ !> Corresponds to time unit [s], seconds. \n\n
+ double precision, parameter :: tunit_const = 1.0d0
+
+ !> @brief Transient computation switch.
+ !> @details
+ !> Transient computation switch. \n
+ !> `.true.`: transient computation. \n
+ !> `.false.`: steady state computation.
+ logical transient
+
+ !> @brief Maximum number of time periods.
+ !> @details
+ !> Maximum number of time periods. \n
+ integer, parameter :: npermax = 1056
+
+ !> @brief Maximum simulation time.
+ !> @details
+ !> Maximum simulation time. \n\n
+ !>
+ !> Read under `# time periods`. Set to the end time of the
+ !> last time period.
+ double precision max_simtime
+
+ !> @brief Start of simulation time.
+ !> @details
+ !> Start of simulation time. \n\n
+ !>
+ !> Read under `# timestep control` (second line, fourth entry)
+ !> or under `# tstart`.
+ !>
+ !> "simtime_0" is needed for inverse-restart
+ double precision simtime_0
+
+ !> @brief Total number of time steps.
+ !> @details
+ !> Total number of time steps. \n
+ !> Default: 0. \n\n
+ !>
+ !> If `# time periods` is read, the number of time steps is
+ !> recorded in this variable. For variable time step size, the
+ !> value of ntimestep is zero.
+ integer ntimestep
+
+ !> @brief Initial time step index.
+ !> @details
+ !> Initial time step index. \n
+ !> The initial time step index. Default: 0. \n\n
+ !>
+ !> For forward runs, itimestep_0 will set an offset in the time
+ !> index. A simulation of 100 time steps, will then run from
+ !> `itimestep_0` to `100+itimestep_0`. Otherwise, the
+ !> time-handling will be equivalent.\n\n
+ !>
+ !> Read in under `# titer`. \n\n
+ !>
+ !> "itimestep_0" is needed for inverse-restart.
+ integer itimestep_0
+
+ !> @brief Number of time periods.
+ !> @details
+ !> Number of time periods. \n
+ !> The number of time periods is not used if variable time step
+ !> size is defined.
+ integer :: nperiod
+
+ !> @brief Time period specification array.
+ !> @details
+ !> Time period specification array. \n
+ !> - iperiod(ip,1): number of time steps of period ip \n
+ !> - iperiod(ip,2): time step size of period ip \n\n
+ !>
+ !> time step type: 1=linear, 2=logarithmic, 3=jlo (logarithmic
+ !> variation), -2= logarithmic decreasing
+ integer, allocatable, dimension (:,:) :: iperiod
+
+ !> @brief Time period start and end array.
+ !> @details
+ !> Time period start and end array. \n
+ !> - dperiod(ip,1): starting time of period ip \n
+ !> - dperiod(ip,2): ending time of period ip \n\n
+ !>
+ !> Start and end time of the time period are given in time unit
+ !> `tunit`, and then converted into seconds for the rest of the
+ !> computation. \n
+ double precision, allocatable, dimension (:,:) :: dperiod
+
+ !> @brief Static relaxation for flow.
+ !> @details
+ !> Static relaxation for flow. \n
+ !>
+ !> Read under `# timestep control`, first entry.
+ double precision :: thetaf
+
+ !> @brief Static relaxation for temperature.
+ !> @details
+ !> Static relaxation for temperature. \n
+ !>
+ !> Read under `# timestep control`, second entry.
+ double precision :: thetat
+
+ !> @brief Static relaxation for concentration.
+ !> @details
+ !> Static relaxation for concentration. \n
+ !>
+ !> Read under `# timestep control`, third entry.
+ double precision :: thetac
+!
+ logical bctp
+! number of bc-tp entries
+ integer ngsmax
+ integer ngststep, nbctp
+!
+
+ !> @brief Switch for monitor output.
+ !> @details
+ !> Switch for monitor output. \n\n
+ logical :: monitor
+
+ integer nmon,imon(npermax,4)
+
+ !> @brief Number of output times.
+ !> @details
+ !> Number of output times. \n
+ !> Records entry under `# output times`.
+ integer noutt
+
+end module mod_time
diff --git a/forward/model_init.f90 b/forward/model_init.f90
new file mode 100644
index 0000000..71374e6
--- /dev/null
+++ b/forward/model_init.f90
@@ -0,0 +1,75 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief inititialise cache/block size
+!> @details
+!> initialise cache size and block parameters\n
+!> and numerical basis constants (zero values, precision ...)\n
+ SUBROUTINE model_init(ismpl)
+ USE arrays
+ use mod_genrl
+ use mod_blocking_size
+ IMPLICIT NONE
+ integer :: ismpl
+ DOUBLE PRECISION dlamch
+ EXTERNAL dlamch
+ INTRINSIC dsqrt
+
+! !! defines lin. solver constants [part 1] !!
+ bldiv_cg = 7.0D0
+ bldiv_bicg(1) = 10.5D0
+ bldiv_bicg(2) = 5.5D0
+ bldiv_mvp = 11.5D0
+ bldiv_dot(1) = 2.0D0
+ bldiv_dot(2) = 6.5D0
+ bldiv_dot(3) = 8.0D0
+!
+! !! defines lin. solver constants [part 2] !!
+#ifdef CLsun
+! cache size for SUN Ultra-Sparc-III (8 MByte) cpu
+ cache_size = 384000
+#elif CLopt
+! cache size for AMD Opteron (1 MByte) cpu
+ cache_size = 1024000
+#elif CLpen
+! cache size for Intel P4 (512 KByte) cpu
+ cache_size = 512000
+#else
+! cache size for Intel P4/Celeron (128 KByte) cpu
+ cache_size = 128000
+#endif
+! block size (number of doubles minus 20%)
+ bl_size = cache_size / 10
+
+! initalise some values
+ memory = 0.0D0
+
+ const_dble(1) = dlamch('E')
+! 3/4 of the min value
+ const_dble(2) = dsqrt(dlamch('U'))
+ const_dble(2) = const_dble(2)*dsqrt(const_dble(2))
+! 3/4 of the max value
+ const_dble(3) = dsqrt(dlamch('O'))
+ const_dble(3) = const_dble(3)*dsqrt(const_dble(3))
+
+ RETURN
+ END
diff --git a/forward/nlrelaxad.f90 b/forward/nlrelaxad.f90
new file mode 100644
index 0000000..8914776
--- /dev/null
+++ b/forward/nlrelaxad.f90
@@ -0,0 +1,68 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief adaptive relaxation parameter
+!> @param[in] iter iteration counter
+!> @param[in] r <description>
+!> @param[in] rold <description>
+!> @param[in] emax <description>
+!> @param[out] relax current relaxation value
+!> @param[in,out] relaxold old relaxation value
+!> @param[in] ismpl local sample index
+!> @details
+!> calculate adaptive relaxation parameter\n
+!> see Cooley (1983), WRR 19(5), 1271-1285\n
+ SUBROUTINE nl_relax(iter,r,rold,emax,relax,relaxold,ismpl)
+ use mod_genrl
+ use mod_genrlc
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ INTEGER iter
+ DOUBLE PRECISION r, rold, emax, relax, relaxold, s
+
+! step 1
+ IF (iter==1) THEN
+ s = 1.0D0
+ ELSE
+ s = r/(relaxold*rold)
+ END IF
+ WRITE(*,*) 'r, rold =', r, rold, ' s= ', s
+! step 2
+ IF (s>=-1.D0) THEN
+ relax = (3.D0+s)/(3.D0+abs(s))
+ ELSE
+ relax = 0.5D0/abs(s)
+ END IF
+! step 3
+ IF (relax*abs(r)>emax) relax = emax/abs(r)
+ relax = min(1.D0,max(0.05D0,relax))
+ WRITE(*,*) '**** relax= ', relax, ' (', relaxold, ')'
+!
+ relaxold = relax
+!
+ IF (linfos(3)>=1) THEN
+ WRITE(*,'(1a,1e10.3)') ' relaxation factor: ', relax
+ END IF
+!
+ RETURN
+ END
diff --git a/forward/no_ext_link.f90 b/forward/no_ext_link.f90
new file mode 100644
index 0000000..fffbb4e
--- /dev/null
+++ b/forward/no_ext_link.f90
@@ -0,0 +1,208 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief extract extern file name and read the double precision array 'A'
+!> @param[in] NI i-direction array dimension
+!> @param[in] NJ j-direction array dimension
+!> @param[in] NK k-direction array dimension
+!> @param[in] A_name array name (ascii)
+!> @param[in] name_link line for extracting
+!> @param[out] A array with all data
+!> @return "true" it was not an external file, FALSE: data from external file readed
+ LOGICAL FUNCTION no_ext_link(ni,nj,nk,a,a_name,name_link)
+ use mod_genrlc
+ IMPLICIT NONE
+ INTEGER i1, i2
+ character (len=80) :: defaultname
+! arrayname and filename
+ character (len=*) :: a_name
+!
+ INTEGER ni, nj, nk
+ INTEGER j, k
+ DOUBLE PRECISION a(ni,nj,nk)
+!
+ character (len=*) :: name_link
+!
+ INTEGER sfirst, end_sec
+ EXTERNAL sfirst
+!
+ LOGICAL is_txt
+
+! default HDF5 input file name
+ CALL chln(project,i1,i2)
+!
+ is_txt = .FALSE.
+ CALL get_arg('HDF5',name_link,j,k)
+ defaultname = project(i1:i2) // '.h5'
+ IF (j<1 .OR. k<j) THEN
+ is_txt = .TRUE.
+ CALL get_arg('TXT',name_link,j,k)
+ defaultname = project(i1:i2) // '.txt'
+ IF (j<1 .OR. k<j) THEN
+ no_ext_link = .TRUE.
+ RETURN
+ END IF
+ END IF
+! end of the section name
+ end_sec = sfirst(name_link)
+!
+! found extern file declaration
+ IF (name_link(j:k)=='default') THEN
+ IF (is_txt) THEN
+ CALL read_open_txt(ni,nj,nk,a,name_link(1:end_sec), &
+ defaultname)
+ ELSE
+ CALL read_hdf5(ni,nj,nk,a,a_name,defaultname)
+ END IF
+ ELSE
+ IF (is_txt) THEN
+ CALL read_open_txt(ni,nj,nk,a,name_link(1:end_sec), &
+ name_link(j:k))
+ ELSE
+ CALL read_hdf5(ni,nj,nk,a,a_name,name_link(j:k))
+ END IF
+ END IF
+ no_ext_link = .FALSE.
+!
+ RETURN
+ END
+
+!> @brief extract extern file name and read the integer array 'A'
+!> @param[in] NI i-direction array dimension
+!> @param[in] NJ j-direction array dimension
+!> @param[in] NK k-direction array dimension
+!> @param[in] A_name array name (ascii)
+!> @param[in] name_link line for extracting
+!> @param[out] A array with all data
+!> @return "true" it was not an external file, FALSE: data from external file readed
+ LOGICAL FUNCTION no_ext_link_int(ni,nj,nk,a,a_name,name_link)
+ use mod_genrlc
+ IMPLICIT NONE
+ INTEGER i1, i2
+ character (len=80) :: defaultname
+! arrayname and filename
+ character (len=*) :: a_name
+!
+ INTEGER ni, nj, nk
+ INTEGER j, k
+ INTEGER a(ni,nj,nk)
+!
+ character (len=*) :: name_link
+!
+ INTEGER sfirst, end_sec
+ EXTERNAL sfirst
+!
+ LOGICAL is_txt
+
+! default HDF5 input file name
+ CALL chln(project,i1,i2)
+ defaultname = project(i1:i2) // '.h5'
+!
+ is_txt = .FALSE.
+ CALL get_arg('HDF5',name_link,j,k)
+ IF (j<1 .OR. k<j) THEN
+ is_txt = .TRUE.
+ CALL get_arg('TXT',name_link,j,k)
+ IF (j<1 .OR. k<j) THEN
+ no_ext_link_int = .TRUE.
+ RETURN
+ END IF
+ END IF
+! end of the section name
+ end_sec = sfirst(name_link)
+!
+! found extern file declaration
+ IF (name_link(j:k)=='default') THEN
+ IF (is_txt) THEN
+ CALL read_open_txt_int(ni,nj,nk,a,name_link(1:end_sec), &
+ defaultname)
+ ELSE
+ CALL read_hdf5_int(ni,nj,nk,a,a_name,defaultname)
+ END IF
+ ELSE
+ IF (is_txt) THEN
+ CALL read_open_txt_int(ni,nj,nk,a,name_link(1:end_sec), &
+ name_link(j:k))
+ ELSE
+ CALL read_hdf5_int(ni,nj,nk,a,a_name,name_link(j:k))
+ END IF
+ END IF
+ no_ext_link_int = .FALSE.
+!
+ RETURN
+ END
+
+!> @brief read double precision data from file
+!> @param[in] NI i-direction array dimension
+!> @param[in] NJ j-direction array dimension
+!> @param[in] NK k-direction array dimension
+!> @param[in] A_name array name (ascii)
+!> @param[in] f_name file name
+!> @param[out] A array with all data
+ SUBROUTINE read_open_txt(ni,nj,nk,a,a_name,f_name)
+ IMPLICIT NONE
+ character (len=*) :: a_name, f_name
+ character (len=80) :: line
+ INTEGER ni, nj, nk, i, j, k
+ DOUBLE PRECISION a(ni,nj,nk)
+ LOGICAL found
+ EXTERNAL found
+
+ WRITE(*,*) ' open TXT file: ', f_name
+ OPEN(89,file=f_name,status='old',err=99)
+ IF (found(89,a_name,line,.TRUE.)) THEN
+ READ(89,*) (((a(i,j,k),i=1,ni),j=1,nj),k=1,nk)
+ END IF
+ CLOSE(89)
+ RETURN
+!
+99 WRITE(*,*) 'error: can not open file "', f_name, '" !'
+ STOP
+ END
+
+!> @brief read integer data from file
+!> @param[in] NI i-direction array dimension
+!> @param[in] NJ j-direction array dimension
+!> @param[in] NK k-direction array dimension
+!> @param[in] A_name array name (ascii)
+!> @param[in] f_name file name
+!> @param[out] A array with all data
+ SUBROUTINE read_open_txt_int(ni,nj,nk,a,a_name,f_name)
+ IMPLICIT NONE
+ character (len=*) :: a_name, f_name
+ character (len=80) :: line
+ INTEGER ni, nj, nk, i, j, k
+ INTEGER a(ni,nj,nk)
+ LOGICAL found
+ EXTERNAL found
+
+ WRITE(*,*) ' open TXT file: ', f_name
+ OPEN(89,file=f_name,status='old',err=99)
+ IF (found(89,a_name,line,.TRUE.)) THEN
+ READ(89,*) (((a(i,j,k),i=1,ni),j=1,nj),k=1,nk)
+ END IF
+ CLOSE(89)
+ RETURN
+!
+99 WRITE(*,*) 'error: can not open file "', f_name, '" !'
+ STOP
+ END
diff --git a/forward/old_restore.f90 b/forward/old_restore.f90
new file mode 100644
index 0000000..bb53d4d
--- /dev/null
+++ b/forward/old_restore.f90
@@ -0,0 +1,73 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief parallelisation wrapper for "omp_old_restore"
+!> @param[in] level level number
+!> @param[in] ismpl local sample index
+ SUBROUTINE old_restore(level,ismpl)
+ use mod_genrl
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ integer :: ismpl
+
+ INCLUDE 'OMP_TOOLS.inc'
+ INTEGER level
+ INTRINSIC abs
+
+#ifdef fOMP
+!$OMP parallel num_threads(Tlevel_1)
+!$ call omp_binding(abs(ismpl))
+#endif
+ CALL omp_old_restore(level,ismpl)
+#ifdef fOMP
+!$OMP end parallel
+#endif
+!
+ RETURN
+ END
+
+!> @brief restores an old state/version
+!> @param[in] level level number (which old version)
+!> @param[in] ismpl local sample index
+ SUBROUTINE omp_old_restore(level,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_conc
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k, l
+
+ INTEGER level, tpos, tanz
+ INTRINSIC abs, max
+
+ CALL omp_part(i0*j0*k0,tpos,tanz)
+ CALL ijk_m(tpos,i,j,k)
+! save state (before)
+ CALL dcopy(tanz,headold(tpos,level,abs(ismpl)),1, head(i,j,k,max(1,ismpl)), 1)
+ CALL dcopy(tanz,tempold(tpos,level,abs(ismpl)),1, temp(i,j,k,max(1,ismpl)), 1)
+ CALL dcopy(tanz,presold(tpos,level,abs(ismpl)),1, pres(i,j,k,max(1,ismpl)), 1)
+ DO l = 1, ntrans
+ CALL dcopy(tanz,concold(tpos,l,level,abs(ismpl)),1, conc(i,j,k,l,max(1,ismpl)),1)
+ END DO
+!
+ RETURN
+ END
diff --git a/forward/old_save.f90 b/forward/old_save.f90
new file mode 100644
index 0000000..282305c
--- /dev/null
+++ b/forward/old_save.f90
@@ -0,0 +1,99 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief parallelisation wrapper for "omp_old_save"
+!> @param[in] level level number
+!> @param[in] ismpl local sample index
+ subroutine old_save(level,ismpl)
+
+ use mod_OMP_TOOLS, only: Tlevel_1
+
+ implicit none
+
+ integer :: ismpl
+
+ include 'OMP_TOOLS.inc'
+
+ integer, intent (in) :: level
+
+
+#ifdef fOMP
+!$OMP parallel num_threads(Tlevel_1)
+!$ call omp_binding(abs(ismpl))
+#endif
+
+ call omp_old_save(level,ismpl)
+
+#ifdef fOMP
+!$OMP end parallel
+#endif
+!
+ return
+
+ end subroutine old_save
+
+!> @brief save current state as an old version
+!> @param[in] level level number (which old version)
+!> @param[in] ismpl local sample index
+ subroutine omp_old_save(level,ismpl)
+
+ use arrays
+ use mod_genrl
+ use mod_conc
+
+ implicit none
+
+ ! local sample index
+ integer :: ismpl
+
+ ! cgen level index
+ integer, intent (in) :: level
+
+ ! directional cell-indices
+ integer :: i, j, k
+
+ ! counter for concentration
+ integer :: l
+
+ ! Start position in array for process
+ integer :: tpos
+
+ ! Number of array elements for process
+ integer :: tanz
+
+ ! OpenMP partition, get tpos, tanz
+ call omp_part(i0*j0*k0,tpos,tanz)
+
+ ! Get i, j, k indices for tpos
+ call ijk_m(tpos,i,j,k)
+
+ ! Copy all variable arrays to old: var -> varold
+ call dcopy(tanz,head(i,j,k,abs(ismpl)),1, headold(tpos,level,max(1,ismpl)), 1)
+ call dcopy(tanz,temp(i,j,k,abs(ismpl)),1, tempold(tpos,level,max(1,ismpl)), 1)
+ call dcopy(tanz,pres(i,j,k,abs(ismpl)),1, presold(tpos,level,max(1,ismpl)), 1)
+ do l = 1, ntrans
+ call dcopy(tanz,conc(i,j,k,l,abs(ismpl)),1, concold(tpos,l,level,max(1,ismpl)),1)
+ end do
+
+ return
+
+ end subroutine omp_old_save
diff --git a/forward/omp_bindtools.f90 b/forward/omp_bindtools.f90
new file mode 100644
index 0000000..eb6daa3
--- /dev/null
+++ b/forward/omp_bindtools.f90
@@ -0,0 +1,262 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief init thread binding table for ScaleMP systems
+ SUBROUTINE init_scalemp_binding()
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+! node-size: core number to use per node, offset for the next node
+ INTEGER node_size, node_offs
+ INTEGER o, i, bs, k, ni
+ ! INTEGER g_o, g_i
+! binding table
+ INTEGER po, pi, mo, mi
+ PARAMETER (po=128)
+ PARAMETER (pi=128)
+ INTEGER (kind=4) btable(pi,po)
+ COMMON /binding_tab/mo, mi, btable
+! node list
+ INTEGER inode_list(po+1), nnode
+ character (len=256) :: cnode_list
+! error handler
+ INTEGER error
+!
+ INTRINSIC trim, mod
+#ifdef libnuma
+ INTEGER (kind=4) f_numa_num_configured_nodes
+ INTEGER (kind=4) f_numa_num_configured_cpus
+ INTEGER (kind=4) f_numa_available
+ EXTERNAL f_numa_num_configured_nodes
+ EXTERNAL f_numa_num_configured_cpus
+ EXTERNAL f_numa_available
+#endif
+
+! default for old ScaleMP system (on RWTH Aachen university)
+ node_size = 8
+ node_offs = node_size
+#ifdef libnuma
+! overwrite for modern systems using libnuma
+ IF (f_numa_available()==-1) THEN
+ WRITE(*,'(1A)') &
+ 'error: "libnuma" not working, see "omp_bindtools.f90"!'
+ STOP
+ END IF
+ node_size = f_numa_num_configured_cpus() / &
+ f_numa_num_configured_nodes()
+ node_offs = node_size
+ WRITE(*,'(1A,1I4)') ' [I] : ccNUMA nodes = ', &
+ f_numa_num_configured_nodes()
+ WRITE(*,'(1A,1I4)') &
+ ' [I] : cores per ccNUMA node = ', node_size
+#endif
+!
+ CALL get_environment_variable(name='JOB_NODE_LIST', &
+ value=cnode_list,status=error)
+ IF (error==0) THEN
+! default value to overwrite
+ DO i = 1, po + 1
+ inode_list(i) = -1
+ END DO
+ WRITE(*,*) ' [I] : JOB_NODE_LIST = "', trim(cnode_list), &
+ '"'
+! read node list
+ READ(cnode_list,*,err=101,end=101) (inode_list(i),i=1,po)
+101 nnode = 0
+! count node number
+ DO i = 1, po
+ IF (inode_list(i)>=0) nnode = nnode + 1
+ END DO
+ ELSE
+! default setup, assume all nodes
+ WRITE(*,'(2A)') ' <D> : JOB_NODE_LIST not defined,', &
+ ' using all ccNUMA nodes'
+ nnode = 1
+#ifdef libnuma
+ nnode = f_numa_num_configured_nodes()
+#endif
+ DO i = 1, nnode
+ inode_list(i) = i-1
+ END DO
+ inode_list(nnode+1) = -1
+ END IF
+ WRITE(*,'(1A,999I6)') ' nodes = ', &
+ (inode_list(i),i=1,nnode)
+!
+ mi = tlevel_1
+ mo = tlevel_0
+! threading block size [bs] for inner parallel region
+ bs = (node_size*nnode) / tlevel_0
+!
+ IF (bs>=tlevel_1) THEN
+ WRITE(*,'(1A,3I6)') ' [I] : binding mode = memory distance'
+! compute binding list
+ DO o = 1, mo
+ DO i = 1, mi
+ k = (o-1)*bs +(i-1)*bs/tlevel_1
+ ni = k / node_size + 1
+ btable(i,o) = inode_list(ni)*node_offs +k-(ni-1)*node_size
+ END DO
+ END DO
+ ELSE
+ WRITE(*,*) ' [E] : not enough cores for all threads'
+ STOP
+ END IF
+! show table
+ WRITE(*,*) ' [I] : binding table'
+ WRITE(*,'(1A,2I6)') ' ', mo, mi
+ DO o = 1, mo
+ WRITE(*,'(1A,128I6)') ' ', (btable(i,o),i=1,mi)
+ END DO
+!
+ RETURN
+ END
+
+!> @brief load thread binding table
+!> @param[in] fname file name of the table
+ SUBROUTINE load_binding(fname)
+ IMPLICIT NONE
+ character (len=*) :: fname
+ INTEGER po, pi, mo, mi
+#ifdef TBIND
+ INTEGER o, i
+#endif
+ PARAMETER (po=128)
+ PARAMETER (pi=128)
+ INTEGER (kind=4) :: btable(pi,po)
+ COMMON /binding_tab/mo, mi, btable
+ INTRINSIC trim
+
+#ifdef TBIND
+ IF (fname=='default') THEN
+ WRITE(*,*) ' <D> : no thread binding'
+ mo = 0
+ mi = 0
+ ELSE
+ WRITE(*,*) ' [R] : thread binding table from "', &
+ trim(fname), '"'
+ OPEN(81,file=fname,status='OLD',err=100)
+ READ(81,*) mo, mi
+ IF (mo>po .OR. mi>pi .OR. mo<=0 .OR. mi<=0) THEN
+ WRITE(*,'(2(1A,1I4),1A)') &
+ 'error: processor binding table exceed limits (', po, &
+ 'x', pi, ') in "load_binding" !'
+ STOP
+ END IF
+ DO o = 1, mo
+ READ(81,*) (btable(i,o),i=1,mi)
+ END DO
+ CLOSE(81)
+ END IF
+! show table
+ WRITE(*,*) ' [I] : binding table'
+ WRITE(*,'(1A,2I6)') ' ', mo, mi
+ DO o = 1, mo
+ WRITE(*,'(1A,128I6)') ' ', (btable(i,o),i=1,mi)
+ END DO
+#endif
+ RETURN
+#ifdef TBIND
+100 WRITE(*,'(3A)') 'error: can not open map file "', &
+ trim(fname), '" !'
+#endif
+ STOP
+ END
+
+!> @brief try thread binding
+!> @param[in] o outer thread index
+ SUBROUTINE omp_binding(o)
+ use mod_genrl
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ INTEGER o
+#ifdef TBIND
+ INTEGER lo
+#endif
+ INCLUDE 'OMP_TOOLS.inc'
+ INTEGER p_o, p_i, mo, mi
+ PARAMETER (p_o=128)
+ PARAMETER (p_i=128)
+ INTEGER (kind=4) :: btable(p_i,p_o)
+ COMMON /binding_tab/mo, mi, btable
+! master binding staff
+#ifdef TBIND
+ INTEGER (kind=4) :: p_is
+#endif
+#ifdef libnuma
+ INTEGER (kind=4) :: f_numa_run_on_node
+ INTEGER (kind=4 :: f_numa_node_of_cpu
+ INTEGER (kind=4) :: f_numa_available
+ EXTERNAL f_numa_run_on_node
+ EXTERNAL f_numa_node_of_cpu
+ EXTERNAL f_numa_available
+#endif
+ INTRINSIC mod
+
+#ifdef libnuma
+ IF (f_numa_available()==-1) THEN
+ WRITE(*,'(1A)') &
+ 'error: "libnuma" not working, see "omp_bindtools.f90"!'
+ STOP
+ END IF
+#endif
+#ifdef TBIND
+! binding enabled?
+ IF (mo==0 .OR. mi==0) RETURN
+!
+ i = omp_get_his_thread_num() + 1
+ lo = o
+! special handling for ENKF/SIMUL, when fewer threads than realisations
+ IF (lo>Tlevel_0 .AND. lo<=nsmpl) lo = mod(lo-1,Tlevel_0) +1
+!
+ IF (lo>mo .OR. i>mi .OR. lo<1 .OR. i<1) THEN
+ WRITE(*,'(2(1A,1I4),1A)') &
+ 'error: processor binding table exceed limits (', mo, 'x', &
+ mi, ') in "omp_binding" !'
+ WRITE(*,'(2(1A,1I4),1A)') &
+ ' for processor binding on (', lo, 'x', i, ')'
+ STOP
+ END IF
+#ifdef libnuma
+ IF (f_numa_run_on_node(f_numa_node_of_cpu(btable(i,lo)))<0) THEN
+ WRITE(*,'(1A)') &
+ 'error: "libnuma" not working, see "omp_bindtools.f90"!'
+ STOP
+ END IF
+#else
+#ifndef G95
+! Intel, PGI, SUN
+ CALL r_processorbind(btable(i,lo))
+#else
+! GNU 4.xx, to avoid THREAD-spinning on the master affinity
+ IF (i>1) THEN
+ CALL r_processorbind(btable(i,lo))
+ ELSE
+! (GNU compiler workaround) bind the master thread on all team cores (group binding)
+ p_is = mi
+ CALL r_groupbind(p_is,btable(1,lo))
+ END IF
+#endif
+#endif
+#endif
+ RETURN
+ END
diff --git a/forward/omp_file_handler.f90 b/forward/omp_file_handler.f90
new file mode 100644
index 0000000..372094a
--- /dev/null
+++ b/forward/omp_file_handler.f90
@@ -0,0 +1,94 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief create a new file handler (number)
+!> @param[out] fh file handler (number)
+!> @param[in] i 0: reset file handler table, >0 : handler index, specific for each thread
+ SUBROUTINE omp_new_file_handler(fh,i)
+ use arrays
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+ INTEGER fh, i, o, l2
+
+! reset the file-handler table
+ IF (i==0) THEN
+ l2 = tlevel_0
+ DO fh = 1, c_fhandler
+ DO o = 1, l2
+ fh_table(fh,o) = 0
+ END DO
+ END DO
+ fh = -1
+ RETURN
+ END IF
+!
+ o = omp_get_his_thread_num()
+! looking for an already used file-handler (for this thread)
+ DO l2 = 1, c_fhandler
+ IF (fh_table(l2,o+1)==i) THEN
+ fh = l2 + o*c_fhandler + c_foffset
+ RETURN
+ END IF
+ END DO
+! looking for a free file-handler (not used from any thread)
+ DO l2 = 1, c_fhandler
+ IF (fh_table(l2,o+1)==0) THEN
+ fh_table(l2,o+1) = i
+ fh = l2 + o*c_fhandler + c_foffset
+ RETURN
+ END IF
+ END DO
+! error handler
+ WRITE(*,'(1A,1I4,1A)') 'error: max number (', c_fhandler, &
+ ') of open files per thread, in "omp_file_handler.f" !'
+ STOP
+ END
+
+!> @brief remove used file handler (number)
+!> @param[in,out] fh file handler (number), gets 0 when successful
+ SUBROUTINE omp_del_file_handler(fh)
+ use arrays
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+ INTEGER fh, o, l2
+
+ o = omp_get_his_thread_num()
+ l2 = fh - o*c_fhandler - c_foffset
+! sanity check
+ IF (l2<=0 .OR. l2>c_fhandler) THEN
+ WRITE(*,'(1A)') &
+ 'error: wrong file-handler, in "omp_file_handler.f" !'
+ STOP
+ END IF
+! free the already used file-handler
+ IF (fh_table(l2,o+1)/=0) THEN
+ fh_table(l2,o+1) = 0
+ fh = 0
+ RETURN
+ END IF
+! error handler
+ WRITE(*,'(1A,1I4,1A)') 'error: file-handler ', fh, &
+ ' already closed, in "omp_file_handler.f" !'
+ STOP
+ END
diff --git a/forward/omp_libnuma.c b/forward/omp_libnuma.c
new file mode 100644
index 0000000..7951aa3
--- /dev/null
+++ b/forward/omp_libnuma.c
@@ -0,0 +1,50 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+#ifdef libnuma
+#include <numa.h>
+
+int f_numa_node_of_cpu_(int *id)
+{
+ return(numa_node_of_cpu(*id));
+}
+
+int f_numa_run_on_node_(int *id)
+{
+ return(numa_run_on_node(*id));
+}
+
+int f_numa_num_configured_nodes_()
+{
+ return(numa_num_configured_nodes());
+}
+
+int f_numa_num_configured_cpus_()
+{
+ return(numa_num_configured_cpus());
+}
+
+int f_numa_available_()
+{
+ return(numa_available());
+}
+#endif
diff --git a/forward/omp_summe.f90 b/forward/omp_summe.f90
new file mode 100644
index 0000000..87df45d
--- /dev/null
+++ b/forward/omp_summe.f90
@@ -0,0 +1,139 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief OpenMP "reduction" collection used in Courant/Peclet/Neumann computations
+!> @param[in,out] dval_maxx max X value
+!> @param[in,out] dval_minx min X value
+!> @param[in,out] dval_avgx sum, X value
+!> @param[in,out] dval_maxy max Y value
+!> @param[in,out] dval_miny min Y value
+!> @param[in,out] dval_avgy sum, Y value
+!> @param[in,out] dval_maxz max Z value
+!> @param[in,out] dval_minz min Z value
+!> @param[in,out] dval_avgz sum, Z value
+!> @param[in,out] c1 number in X
+!> @param[in,out] c2 number in Y
+!> @param[in,out] c3 number in Z
+!> @param[in] ismpl local sample index
+!> @details
+!> computes global (inter) thread maximum, minimum and sum (float and integer)\n
+ SUBROUTINE omp_summe(dval_maxx,dval_minx,dval_avgx,dval_maxy, &
+ dval_miny,dval_avgy,dval_maxz,dval_minz,dval_avgz,c1,c2,c3, &
+ ismpl)
+ use arrays
+ use mod_genrl
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j
+ INCLUDE 'OMP_TOOLS.inc'
+ DOUBLE PRECISION dval_maxx, dval_minx, dval_avgx, dval_maxy, &
+ dval_miny, dval_avgy, dval_maxz, dval_minz, dval_avgz
+ INTEGER c1, c2, c3, myid
+
+! each thread needs to set its private values in the global arrays
+ myid = omp_get_his_thread_num() + 1
+!
+ omp_dglobal(myid,1,ismpl) = dval_maxx
+ omp_dglobal(myid,2,ismpl) = dval_minx
+ omp_dglobal(myid,3,ismpl) = dval_avgx
+!
+ omp_dglobal(myid,4,ismpl) = dval_maxy
+ omp_dglobal(myid,5,ismpl) = dval_miny
+ omp_dglobal(myid,6,ismpl) = dval_avgy
+!
+ omp_dglobal(myid,7,ismpl) = dval_maxz
+ omp_dglobal(myid,8,ismpl) = dval_minz
+ omp_dglobal(myid,9,ismpl) = dval_avgz
+!
+ omp_iglobal(myid,1,ismpl) = c1
+ omp_iglobal(myid,2,ismpl) = c2
+ omp_iglobal(myid,3,ismpl) = c3
+!
+! global OpenMP reduction
+!$OMP barrier
+!$OMP master
+! fast OpenMP reduction MAX
+ DO i = 2, tlevel_1
+ omp_dglobal(1,1,ismpl) = max(omp_dglobal(1,1,ismpl), &
+ omp_dglobal(i,1,ismpl))
+ END DO
+ DO i = 2, tlevel_1
+ omp_dglobal(1,4,ismpl) = max(omp_dglobal(1,4,ismpl), &
+ omp_dglobal(i,4,ismpl))
+ END DO
+ DO i = 2, tlevel_1
+ omp_dglobal(1,7,ismpl) = max(omp_dglobal(1,7,ismpl), &
+ omp_dglobal(i,7,ismpl))
+ END DO
+! fast OpenMP reduction MIN
+ DO i = 2, tlevel_1
+ omp_dglobal(1,2,ismpl) = min(omp_dglobal(1,2,ismpl), &
+ omp_dglobal(i,2,ismpl))
+ END DO
+ DO i = 2, tlevel_1
+ omp_dglobal(1,5,ismpl) = min(omp_dglobal(1,5,ismpl), &
+ omp_dglobal(i,5,ismpl))
+ END DO
+ DO i = 2, tlevel_1
+ omp_dglobal(1,8,ismpl) = min(omp_dglobal(1,8,ismpl), &
+ omp_dglobal(i,8,ismpl))
+ END DO
+! fast OpenMP reduction SUM
+ DO i = 2, tlevel_1
+ omp_dglobal(1,3,ismpl) = omp_dglobal(1,3,ismpl) + &
+ omp_dglobal(i,3,ismpl)
+ END DO
+ DO i = 2, tlevel_1
+ omp_dglobal(1,6,ismpl) = omp_dglobal(1,6,ismpl) + &
+ omp_dglobal(i,6,ismpl)
+ END DO
+ DO i = 2, tlevel_1
+ omp_dglobal(1,9,ismpl) = omp_dglobal(1,9,ismpl) + &
+ omp_dglobal(i,9,ismpl)
+ END DO
+! fast OpenMP reduction SUM (integer)
+ DO j = 1, 3
+ DO i = 2, tlevel_1
+ omp_iglobal(1,j,ismpl) = omp_iglobal(1,j,ismpl) + &
+ omp_iglobal(i,j,ismpl)
+ END DO
+ END DO
+!$OMP end master
+!$OMP barrier
+!
+! each thread gets its own copy of the global reduction
+ dval_maxx = omp_dglobal(1,1,ismpl)
+ dval_minx = omp_dglobal(1,2,ismpl)
+ dval_avgx = omp_dglobal(1,3,ismpl)
+ dval_maxy = omp_dglobal(1,4,ismpl)
+ dval_miny = omp_dglobal(1,5,ismpl)
+ dval_avgy = omp_dglobal(1,6,ismpl)
+ dval_maxz = omp_dglobal(1,7,ismpl)
+ dval_minz = omp_dglobal(1,8,ismpl)
+ dval_avgz = omp_dglobal(1,9,ismpl)
+ c1 = omp_iglobal(1,1,ismpl)
+ c2 = omp_iglobal(1,2,ismpl)
+ c3 = omp_iglobal(1,3,ismpl)
+!
+ RETURN
+ END
diff --git a/forward/output/write_data.f90 b/forward/output/write_data.f90
new file mode 100644
index 0000000..4009a44
--- /dev/null
+++ b/forward/output/write_data.f90
@@ -0,0 +1,113 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief shows observation data differences
+!> @param[in] ident index number for file name
+!> @param[in] ismpl local sample index
+ SUBROUTINE write_data(ident,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_flow
+ use mod_temp
+ use mod_data
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k, l
+ INCLUDE 'version.inc'
+!
+ DOUBLE PRECISION res, val, resn
+ INTEGER i1s, i2s, i1, i2, i3, i4, ui, i_type, ozone, ident, &
+ lblank, i_si, lout
+ EXTERNAL lblank
+ character (len=80) :: filename
+ character (len=20) :: snumber
+
+
+ IF (write_disable) RETURN
+#ifdef NOOUT
+ RETURN
+#endif
+ IF (ndata<=0) RETURN
+
+ CALL omp_new_file_handler(lout,16)
+
+ CALL chln(project,i1,i2)
+ CALL chln(project_sfx(ismpl),i1s,i2s)
+ IF (ident>=0) THEN
+ WRITE(snumber,'(1I7)') ident
+ ELSE IF (ident==-1) THEN
+ WRITE(snumber,'(A20)') 'final'
+ ELSE IF (ident==-2) THEN
+ WRITE(snumber,'(A20)') 'debug'
+ ELSE IF (ident==-3) THEN
+ WRITE(snumber,'(A20)') 'ens_mean'
+ ELSE IF (ident==-4) THEN
+ WRITE(snumber,'(A20)') 'mean'
+ ELSE IF (ident==-5) THEN
+ WRITE(snumber,'(A20)') 'ens_mean'
+ END IF
+ CALL chln(snumber,i3,i4)
+
+ IF (i1s==0) THEN
+ filename = project(i1:i2) // '_' // snumber(i3:i4) // '.dat'
+ ELSE
+ filename = project(i1:i2) // project_sfx(ismpl) (i1s:i2s) // &
+ '_' // snumber(i3:i4) // '.dat'
+ END IF
+
+ OPEN(lout,file=filename,status='unknown',blank='null')
+
+ IF (linfos(3)>=1) THEN
+ WRITE(*,'(3A)') ' [W] : Data to "', &
+ filename(1:lblank(filename)), '"'
+ END IF
+
+ WRITE(lout,'(2A)') '% Shemat-Suite version: ', version
+ WRITE(lout,'(2A)') '% data fit at iteration ', snumber
+ WRITE(lout,'(3A)') '% i j k unit type ', &
+ ' calc obs err', &
+ ' diff res time ozone'
+
+ DO l = 1, ndata
+ i = idata(l,cid_i)
+ j = idata(l,cid_j)
+ k = idata(l,cid_k)
+ ui = uindex(i,j,k)
+ i_type = idata(l,cid_pv)
+ i_si = idata(l,cid_si)
+ ozone = idata(l,cid_obs)
+ val = sdata(l,ismpl)
+
+ res = val - ddata(l,cdd_pv)
+ resn = res/ddata(l,cdd_w)
+ WRITE(lout,'(3i6,3x,i6,3x,i6,3x,6e16.8,i6)') i, j, k, ui, &
+ i_type, val, ddata(l,cdd_pv), ddata(l,cdd_w), res, resn, &
+ ddata(l,cdd_time), ozone
+ END DO
+
+ CLOSE(lout)
+ CALL omp_del_file_handler(lout)
+
+ RETURN
+ END
diff --git a/forward/output/write_dense3d.f90 b/forward/output/write_dense3d.f90
new file mode 100644
index 0000000..6f032b5
--- /dev/null
+++ b/forward/output/write_dense3d.f90
@@ -0,0 +1,90 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief write values in fortran77 compressed text form
+!> @param[in] A value array to write
+!> @param[in] I0 i-dimension
+!> @param[in] J0 j-dimension
+!> @param[in] K0 k-dimension
+!> @param[in] CHAN file handler
+!> @param[in] ismpl local sample index
+ SUBROUTINE write_dense3d(a,i0,j0,k0,chan,ismpl)
+ IMPLICIT NONE
+ INTEGER i0, j0, k0, i, chan, g, nijk, ismpl
+ DOUBLE PRECISION a(i0*j0*k0), va, vn
+! Intel compiler buffer workaround
+ INTEGER maxb, l10, lenb
+ PARAMETER (lenb=65536)
+! character (len=lenB) :: rowbuffer
+ character (len=65536) :: rowbuffer
+! format buffer
+ character (len=25) :: element
+ INTRINSIC dabs, int, log, dble
+
+! init
+ nijk = i0*j0*k0
+ IF (nijk<=0) RETURN
+
+ g = 1
+ maxb = 1
+ va = a(1)
+ IF (dabs(va)<1.0D-99) va = 0.0D0
+ rowbuffer = ' '
+
+! compute minimal place holder for the counter
+ l10 = int(log(dble(nijk+1))/log(10.0D0)) + 1
+ element = '(I' // achar(l10+48) // ',A1,SP,1e24.17,A1)'
+
+ DO i = 2, nijk
+ vn = a(i)
+ IF (dabs(vn)<1.0D-99) vn = 0.0D0
+ IF (vn/=va) THEN
+ IF (g==1) THEN
+ WRITE(rowbuffer(maxb:maxb+25),'(A1,SP,e24.17,A1)') ' ', &
+ va, ','
+ maxb = maxb + 26
+ g = 0
+ ELSE
+ WRITE(rowbuffer(maxb:maxb+25+l10),element) g, '*', va, &
+ ','
+ maxb = maxb + 26 + l10
+ g = 0
+ END IF
+ IF (maxb>=(lenb-26-l10)) THEN
+ WRITE(chan,'(A)') rowbuffer(1:maxb-1)
+ maxb = 1
+ END IF
+ va = vn
+ END IF
+ g = g + 1
+ END DO
+ IF (g==1) THEN
+ WRITE(rowbuffer(maxb:maxb+24),'(A1,SP,1e24.17)') ' ', va
+ maxb = maxb + 25
+ ELSE
+ WRITE(rowbuffer(maxb:maxb+25+l10),element) g, '*', va, ' '
+ maxb = maxb + 26 + l10
+ END IF
+ WRITE(chan,'(A)') rowbuffer(1:maxb-1)
+
+ RETURN
+ END
diff --git a/forward/output/write_logs.f90 b/forward/output/write_logs.f90
new file mode 100644
index 0000000..9f7b748
--- /dev/null
+++ b/forward/output/write_logs.f90
@@ -0,0 +1,98 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief write borehole logs to different files
+!> @param[in] ident index number for file name
+!> @param[in] ismpl local sample index
+ SUBROUTINE write_logs(ident,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_flow
+ use mod_temp
+ use mod_data
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: i, j, k
+ integer :: ismpl
+ INCLUDE 'version.inc'
+!
+ INTEGER i1s, i2s, i1, i2, i3, i4, ui, ident, lblank, lout
+ EXTERNAL lblank
+ character (len=256) :: filename
+ character (len=20) :: snumber
+ INTRINSIC trim
+
+ IF (write_disable) RETURN
+#ifdef NOOUT
+ RETURN
+#endif
+ IF (nbh_logs<=0) RETURN
+!
+ CALL omp_new_file_handler(lout,16)
+!
+ DO ui = 1, nbh_logs
+ CALL chln(project,i1,i2)
+ CALL chln(project_sfx(ismpl),i1s,i2s)
+ IF (ident>=0) THEN
+ WRITE(snumber,'(1I7)') ident
+ ELSE IF (ident==-1) THEN
+ WRITE(snumber,'(A20)') 'final'
+ ELSE IF (ident==-2) THEN
+ WRITE(snumber,'(A20)') 'debug'
+ ELSE IF (ident==-3) THEN
+ WRITE(snumber,'(A20)') 'ens_mean'
+ ELSE IF (ident==-4) THEN
+ WRITE(snumber,'(A20)') 'mean'
+ ELSE IF (ident==-5) THEN
+ WRITE(snumber,'(A20)') 'ens_mean'
+ END IF
+ CALL chln(snumber,i3,i4)
+!
+ IF (i1s==0) THEN
+ filename = project(i1:i2) // '_' // snumber(i3:i4) // '_'//trim(cbh_name(ui))//'.dat'
+ ELSE
+ filename = project(i1:i2) // project_sfx(ismpl) (i1s:i2s) // &
+ '_' // snumber(i3:i4) // '_'//trim(cbh_name(ui))//'.dat'
+ END IF
+!
+ OPEN(lout,file=filename,status='unknown',blank='null')
+!
+ IF (linfos(3)>=1) THEN
+ WRITE(*,'(3A)') ' [W] : Borehole logs to "', &
+ filename(1:lblank(filename)), '"'
+ END IF
+!
+! writing logs at BHT locations
+ i = ibh_pos(1,ui)
+ j = ibh_pos(2,ui)
+ DO k=1,k0
+ WRITE(lout,FMT='(20G23.15)') temp(i,j,k,ismpl),head(i,j,k,ismpl),pres(i,j,k,ismpl),delz(k),uindex(i,j,k)
+ END DO
+!
+ CLOSE(lout)
+ END DO
+!
+ CALL omp_del_file_handler(lout)
+!
+ RETURN
+ END
diff --git a/forward/output/write_monitor.f90 b/forward/output/write_monitor.f90
new file mode 100644
index 0000000..d0384d9
--- /dev/null
+++ b/forward/output/write_monitor.f90
@@ -0,0 +1,303 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief writes data in tecplot-format
+!> @param[in] otype 1: new file, 2 append
+!> @param[in] ismpl local sample index
+ SUBROUTINE write_monitor(otype,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_data
+ use mod_time
+ use mod_flow
+ use mod_temp
+ use mod_conc
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k, m
+ integer :: ib
+ DOUBLE PRECISION dx, dy, dz, val
+! otype:
+! 1 new file
+! 2 append
+ INTEGER otype
+! mm_*: outer iteration loop (file for each monitor point)
+! mt_*: inner iteration loop (file for each time step)
+ INTEGER mm_b, mm_e, mt_b, mt_e
+ INTEGER i1, i2, i3, m2, lblank, lout, in1, in2
+ EXTERNAL lblank
+! external functions
+ DOUBLE PRECISION vxc, vyc, vzc, kx, ky, kz, lx, ly, lz, por, &
+ rhof, visf
+ EXTERNAL vxc, vyc, vzc, kx, ky, kz, lx, ly, lz, por, rhof, &
+ visf
+ DOUBLE PRECISION qxc, qyc, qzc, bhpr
+ EXTERNAL qxc, qyc, qzc, bhpr
+! normal or transposed, monitor point files, time step files
+ LOGICAL ltransposed, lmonip, ltimes
+
+ character (len=256) :: filename
+ character (len=65536) :: line
+ character (len=8) :: snumber
+ INTRINSIC trim
+
+
+ IF ( .NOT. (transient .AND. tr_switch(ismpl))) RETURN
+ IF ( .NOT. monitor) RETURN
+ IF ( .NOT. write_smonitor) THEN
+ IF (write_disable) RETURN
+ END IF
+#ifdef NOMON
+ RETURN
+#endif
+
+ snumber = '0'
+ IF (write_smonitor) THEN
+ WRITE(snumber,'(1I7)') smon_idx(ismpl)
+ IF (smon_idx(ismpl)>=0) THEN
+ WRITE(snumber,'(1I7)') smon_idx(ismpl)
+ ELSE IF (smon_idx(ismpl)==-1) THEN
+ WRITE(snumber,'(A8)') 'final'
+ ELSE IF (smon_idx(ismpl)==-2) THEN
+ WRITE(snumber,'(A8)') 'debug'
+ ELSE IF (smon_idx(ismpl)==-3) THEN
+ WRITE(snumber,'(A8)') 'ens_mean'
+ ELSE IF (smon_idx(ismpl)==-4) THEN
+ WRITE(snumber,'(A8)') 'mean'
+ ELSE IF (smon_idx(ismpl)==-5) THEN
+ WRITE(snumber,'(A8)') 'ens_mean'
+ END IF
+ END IF
+ CALL chln(snumber,in1,in2)
+
+ CALL omp_new_file_handler(lout,16)
+
+! out_orientation:
+! 0 normal (pv column wise), each time step has its own block (mp row wise)
+! 1 transposed (pv row wise), each time step has its own block (mp column wise)
+! 2 normal (pv column wise), new file for each time step (mp row wise)
+! 3 transposed (pv row wise), new file for each time step (mp column wise)
+! 4 normal (pv column wise), new file for each monitor point (time row wise)
+ IF (out_orientation==1 .OR. out_orientation==3) THEN
+ ltransposed = .TRUE.
+ ELSE
+ ltransposed = .FALSE.
+ END IF
+ IF (out_orientation==4) THEN
+! setup outer iteration
+ mm_b = 1
+ mm_e = nmon
+! inner loop makes only one step, computed later
+ mt_b = 0
+ mt_e = 0
+ lmonip = .TRUE.
+ ELSE
+! outer loop makes only one dummy step
+ mm_b = 1
+ mm_e = 1
+! setup inner iteration
+ mt_b = 1
+ mt_e = nmon
+ lmonip = .FALSE.
+ END IF
+ IF (out_orientation==2 .OR. out_orientation==3) THEN
+ ltimes = .TRUE.
+ ELSE
+ ltimes = .FALSE.
+ END IF
+
+ IF (nmon>9999 .AND. ltransposed) THEN
+ WRITE(*,'(1A)') &
+ 'error: number of monitor points limited to 9999!'
+ STOP
+ END IF
+
+ CALL chln(project,i1,i2)
+! steady state - file name
+ WRITE(filename,'(3A)') project(i1:i2),trim(project_sfx(ismpl)), '_monitor.dat'
+ IF (write_smonitor) WRITE(filename,'(5A)') project(i1:i2),trim(project_sfx(ismpl)), &
+ '_monitor_', snumber(in1:in2), '.dat'
+! transient - file name
+ IF (ltimes) THEN
+ WRITE(filename,'(3A,1e15.9,1A)') project(i1:i2),trim(project_sfx(ismpl)), '_', &
+ (simtime(ismpl))/tunit, '_monitor.dat'
+ IF (write_smonitor) WRITE(filename,'(3A,1e15.9,3A)') &
+ project(i1:i2),trim(project_sfx(ismpl)), '_', (simtime(ismpl))/tunit, &
+ '_monitor_', snumber(in1:in2), '.dat'
+ END IF
+
+ IF (linfos(3)>=2 .AND. .NOT. lmonip) THEN
+ WRITE(*,'(3A)') ' [W] : Monitor points to "', &
+ filename(1:lblank(filename)), '"'
+ END IF
+
+! ----------------------------------------------
+ DO m = mm_b, mm_e
+ IF (lmonip) THEN
+! compute inner loop, one step with the right index
+ mt_b = m
+ mt_e = m
+! monitor point - file name
+ CALL chln(project,i1,i2)
+ WRITE(filename,'(3A,1I6.6,1A)') project(i1:i2),trim(project_sfx(ismpl)), '_', m, &
+ '_monitor.dat'
+ IF (write_smonitor) WRITE(filename,'(3A,1I6.6,3A)') &
+ project(i1:i2),trim(project_sfx(ismpl)), '_', m, '_monitor_', snumber(in1:in2), &
+ '.dat'
+ IF (linfos(3)>=2) THEN
+ WRITE(*,'(3A)') ' [W] : Monitor points to "', &
+ filename(1:lblank(filename)), '"'
+ END IF
+ END IF
+
+! Header
+ IF ((otype==1 .OR. ltimes) .AND. .NOT. ltransposed) THEN
+ WRITE(line,'(9999(1A11,1I4.4,1A2))') &
+ (' "conc', i, '",',i=1,ntrans)
+ OPEN(lout,file=filename,status='replace')
+ WRITE(lout,'(12A)') '% "time" "x" ', &
+ ' "y" "z" "uindex" ', &
+ ' "i" "j" "k"', ' "head" ', &
+ ' "temp" ', ' "pres" ', &
+ line(1:ntrans*17), &
+ ' "vx" ', ' "vy" ', &
+ ' "vz" ', ' "bhpr"', &
+ ' "kz" '
+ CLOSE(lout)
+ END IF
+ IF ((otype==1 .OR. ltimes) .AND. ltransposed) THEN
+ OPEN(lout,file=filename,status='replace')
+ WRITE(lout,'(1A)') '% "x"'
+ WRITE(lout,'(1A)') '% "y"'
+ WRITE(lout,'(1A)') '% "z"'
+ WRITE(lout,'(1A)') '% "uindex"'
+ WRITE(lout,'(1A)') '% "i"'
+ WRITE(lout,'(1A)') '% "j"'
+ WRITE(lout,'(1A)') '% "k"'
+ DO m2 = mt_b, mt_e
+ i1 = imon(m2,1)
+ dx = 0.5D0*delx(1)
+ DO i = 2, i1
+ dx = dx + 0.5D0*(delx(i-1)+delx(i))
+ END DO
+ WRITE(lout,'(1e14.6,1X)',advance='NO') dx
+ END DO
+ WRITE(lout,*) ' '
+ DO m2 = mt_b, mt_e
+ i2 = imon(m2,2)
+ dy = 0.5D0*dely(1)
+ DO j = 2, i2
+ dy = dy + 0.5D0*(dely(j-1)+dely(j))
+ END DO
+ WRITE(lout,'(1e14.6,1X)',advance='NO') dy
+ END DO
+ WRITE(lout,*) ' '
+ DO m2 = mt_b, mt_e
+ i3 = imon(m2,3)
+ dz = 0.5D0*delz(1)
+ DO k = 2, i3
+ dz = dz + 0.5D0*(delz(k-1)+delz(k))
+ END DO
+ WRITE(lout,'(1e14.6,1X)',advance='NO') dz
+ END DO
+ WRITE(lout,*) ' '
+ WRITE(lout,'(9999(I14,1X))') (uindex(imon(m2,1),imon(m2,2),imon(m2,3)),m2=mt_b,mt_e)
+ WRITE(lout,'(9999(I14,1X))') (imon(m2,1),m2=mt_b,mt_e)
+ WRITE(lout,'(9999(I14,1X))') (imon(m2,2),m2=mt_b,mt_e)
+ WRITE(lout,'(9999(I14,1X))') (imon(m2,3),m2=mt_b,mt_e)
+ WRITE(lout,'(1A)') '% "head"'
+ WRITE(lout,'(1A)') '% "temp"'
+ WRITE(lout,'(1A)') '% "pres"'
+ DO i = 1, ntrans
+ WRITE(lout,'(1A7,1I4.4,1A1)') '% "conc', i, '"'
+ END DO
+ WRITE(lout,'(1A)') '% "vx"'
+ WRITE(lout,'(1A)') '% "vy"'
+ WRITE(lout,'(1A)') '% "vz"'
+ CLOSE(lout)
+ END IF
+
+! append data block
+ OPEN(lout,file=filename,status='unknown',position='append')
+
+! Body
+ IF ( .NOT. ltransposed) THEN
+! - normal orientation -
+! separate each time steps
+ IF ( .NOT. ltimes .AND. .NOT. lmonip) WRITE(lout,'(A)') '%'
+! - inner loop -
+ DO m2 = mt_b, mt_e
+ i3 = imon(m2,3)
+ i2 = imon(m2,2)
+ i1 = imon(m2,1)
+ dz = 0.5D0*delz(1)
+!
+ val = 0.0d0
+ DO ib = first_flow, last_flow
+ i = ibc_data(ib,cbc_i)
+ j = ibc_data(ib,cbc_j)
+ k = ibc_data(ib,cbc_k)
+! "neumann"?, skip otherwise
+ IF (ibc_data(ib,cbc_bt)==bt_neuw.AND.i==i1.AND.j==i2.AND.k==i3) THEN
+ IF (ibc_data(ib,cbc_bcu)>0) THEN
+ WRITE(*,*) 'error: well function can not be defined in a BC-unit!'
+ STOP
+ END IF
+!better-recompute-all-times instead of: val = dbc_data(ib,3,ismpl)
+ val = bhpr(i,j,k,ismpl)
+ END IF
+ END DO
+!
+ WRITE(lout, &
+ '(1e17.9,3(e14.6,1X),1I9,3I6,9999(e16.8,1X))') &
+ (simtime(ismpl))/tunit, delxa(i1), delya(i2), delza(i3), &
+ uindex(i1,i2,i3), i1, i2, i3, head(i1,i2,i3,ismpl), &
+ temp(i1,i2,i3,ismpl), pres(i1,i2,i3,ismpl)*pa_conv1, &
+ (conc(i1,i2,i3,i,ismpl),i=1, &
+ ntrans), vxc(i1,i2,i3,ismpl), &
+ vyc(i1,i2,i3,ismpl), vzc(i1,i2,i3,ismpl),val*pa_conv1, &
+ kz(i1,i2,i3,ismpl)
+ END DO
+ ELSE
+! - transposed orientation -
+! time comment
+ WRITE(lout,'(1A,1e17.9)') '% "time: "', (simtime(ismpl))/tunit
+ WRITE(lout,'(9999(e14.6,1X))') (head(imon(m2,1),imon(m2,2),imon(m2,3),ismpl),m2=mt_b,mt_e)
+ WRITE(lout,'(9999(e14.6,1X))') (temp(imon(m2,1),imon(m2,2),imon(m2,3),ismpl),m2=mt_b,mt_e)
+ WRITE(lout,'(9999(e14.6,1X))') (pres(imon(m2,1),imon(m2,2),imon(m2,3),ismpl)*pa_conv1,m2=mt_b,mt_e)
+ DO i = 1, ntrans
+ WRITE(lout,'(9999(e14.6,1X))') (conc(imon(m2,1),imon(m2,2),imon(m2,3),i,ismpl),m2=mt_b,mt_e)
+ END DO
+ WRITE(lout,'(9999(e14.6,1X))') (vxc(imon(m2,1),imon(m2,2),imon(m2,3),ismpl),m2=mt_b,mt_e)
+ WRITE(lout,'(9999(e14.6,1X))') (vyc(imon(m2,1),imon(m2,2),imon(m2,3),ismpl),m2=mt_b,mt_e)
+ WRITE(lout,'(9999(e14.6,1X))') (vzc(imon(m2,1),imon(m2,2),imon(m2,3),ismpl),m2=mt_b,mt_e)
+ END IF
+
+ CLOSE(lout)
+ END DO
+! ----------------------------------------------
+ CALL omp_del_file_handler(lout)
+
+ RETURN
+ END
diff --git a/forward/output/write_outt.f90 b/forward/output/write_outt.f90
new file mode 100644
index 0000000..41b9d54
--- /dev/null
+++ b/forward/output/write_outt.f90
@@ -0,0 +1,102 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief determine output times, interpolate, and call the write routine
+!> @param[in] deltt time step length
+!> @param[in] ismpl local sample index
+ SUBROUTINE write_outt(deltt,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_time
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION deltt, talfa, malfa, numdiff
+ DOUBLE PRECISION, ALLOCATABLE :: tmp_new(:,:)
+ INTEGER ijk0, id, ii, i1, i2, i3, i4
+ character (len=80) :: sfx_old
+ INTRINSIC trim
+
+
+ IF (write_disable) RETURN
+
+! allowed numerical difference
+ numdiff = 1.D-14*tunit
+
+ id = 0
+ DO i = 1, noutt + 1
+ IF (outt(i)>simtime(ismpl)+numdiff) THEN
+ id = i - 1
+ GO TO 100
+ END IF
+ END DO
+
+100 IF (id==0) THEN
+! no output
+ RETURN
+ ELSE IF (outt(id)>simtime(ismpl)-deltt+numdiff .AND. &
+ outt(id)<=simtime(ismpl)+numdiff) THEN
+! time interval match
+ ijk0 = i0*j0*k0
+! save current main values
+ ALLOCATE(tmp_new(ijk0,5))
+ CALL dcopy(ijk0,head(1,1,1,ismpl),1,tmp_new(1,1),1)
+ CALL dcopy(ijk0,temp(1,1,1,ismpl),1,tmp_new(1,2),1)
+ CALL dcopy(ijk0,pres(1,1,1,ismpl),1,tmp_new(1,3),1)
+ CALL dcopy(ijk0,conc(1,1,1,1,ismpl),1,tmp_new(1,5),1)
+
+ CALL old_restore(cgen_time,ismpl)
+ ii = 0
+! interpolate
+ talfa = (simtime(ismpl)-outt(id))/deltt
+ malfa = 1.0D0 - talfa
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ ii = ii + 1
+ head(i,j,k,ismpl) = talfa*head(i,j,k,ismpl) + malfa*tmp_new(ii,1)
+ temp(i,j,k,ismpl) = talfa*temp(i,j,k,ismpl) + malfa*tmp_new(ii,2)
+ pres(i,j,k,ismpl) = talfa*pres(i,j,k,ismpl) + malfa*tmp_new(ii,3)
+ conc(i,j,k,1,ismpl) = talfa*conc(i,j,k,1,ismpl) + malfa*tmp_new(ii,5)
+ END DO
+ END DO
+ END DO
+
+ sfx_old = project_sfx(ismpl)
+ project_sfx(ismpl) = trim(sfx_old) // '_time' // &
+ '_out'
+ CALL forward_write(id,ismpl)
+ project_sfx(ismpl) = sfx_old
+
+
+! restore current main values
+ CALL dcopy(ijk0,tmp_new(1,1),1,head(1,1,1,ismpl),1)
+ CALL dcopy(ijk0,tmp_new(1,2),1,temp(1,1,1,ismpl),1)
+ CALL dcopy(ijk0,tmp_new(1,3),1,pres(1,1,1,ismpl),1)
+ CALL dcopy(ijk0,tmp_new(1,5),1,conc(1,1,1,1,ismpl),1)
+ DEALLOCATE(tmp_new)
+ END IF
+
+ RETURN
+ END
diff --git a/forward/output/write_status_log.f90 b/forward/output/write_status_log.f90
new file mode 100644
index 0000000..6341538
--- /dev/null
+++ b/forward/output/write_status_log.f90
@@ -0,0 +1,64 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief naming status.log file and writing header
+!> @param[in] filename input filename as read from shemade.job
+!> @param[inout] ismpl local sample index
+!> @details
+!> The status.log file is named and the header is written.
+subroutine write_status_log(filename, ismpl)
+
+ use mod_genrlc, only: status_log
+ use mod_time, only: transient
+
+ implicit none
+
+ integer :: ismpl
+
+ character (len=80), intent (in) :: filename
+
+ INCLUDE 'version.inc'
+
+ integer, external :: lblank
+ logical, external :: test_option
+
+ status_log = filename(1:lblank(filename)) // '_status.log'
+
+ WRITE(*,'(3A)') ' [W] : "', status_log(1:lblank(status_log)), '"'
+ OPEN(76,file=status_log)
+ WRITE(76,'(2A)') '% Shemat-Suite version: ', version
+ WRITE(76,'(2A)') '% build: ', datum
+ WRITE(76,'(2A)') '% build command line: ', makecmd
+ WRITE(76,'(3A)') '% Project: "', filename(1:lblank(filename)), '"'
+ WRITE(76,'(1A)') '%'
+ IF (transient) THEN
+ WRITE(76,'(3A)') '% <time step>', ' <deltat>', ' <cum time>'
+ END IF
+#ifdef head_base
+ WRITE(76,'(4A)') '% <iteration>',' <delta head>',' <delta temp>',' (<delta conc> ...)'
+#endif
+#ifdef pres_base
+ WRITE(76,'(4A)') '% <iteration>',' <delta pres>',' <delta temp>',' (<delta conc> ...)'
+#endif
+ CLOSE(76)
+
+end subroutine write_status_log
diff --git a/forward/output/write_tecdiff.f90 b/forward/output/write_tecdiff.f90
new file mode 100644
index 0000000..953caea
--- /dev/null
+++ b/forward/output/write_tecdiff.f90
@@ -0,0 +1,137 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief writes diff data in tecplot-format
+!> @param[in] ident index number for output
+!> @param[in] ismpl local sample index
+ SUBROUTINE write_tecdiff(ident,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_data
+ use mod_time
+ use mod_flow
+ use mod_temp
+ use mod_conc
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k, l
+
+
+
+
+
+
+ DOUBLE PRECISION dx, dy, dz
+ INTEGER i1, i2, i3, i4, i1s, i2s, ident, lblank, idx, lout, &
+ locstr, clast
+ EXTERNAL lblank, locstr, clast
+ character (len=256) :: filename
+ character (len=20) :: snumber
+ character (len=1024) :: sline
+
+
+ IF (write_disable) RETURN
+
+ CALL omp_new_file_handler(lout,16)
+
+ CALL chln(project,i1,i2)
+ CALL chln(project_sfx(ismpl),i1s,i2s)
+ IF (ident>=0) THEN
+ WRITE(snumber,'(1I7)') ident
+ ELSE IF (ident==-1) THEN
+ WRITE(snumber,'(A20)') 'final'
+ ELSE IF (ident==-2) THEN
+ WRITE(snumber,'(A20)') 'debug'
+ ELSE IF (ident==-3) THEN
+ WRITE(snumber,'(A20)') 'ens_mean'
+ ELSE IF (ident==-4) THEN
+ WRITE(snumber,'(A20)') 'mean'
+ ELSE IF (ident==-5) THEN
+ WRITE(snumber,'(A20)') 'ens_mean'
+ END IF
+ CALL chln(snumber,i3,i4)
+
+ IF (i1s==0) THEN
+ filename = project(i1:i2) // '_' // snumber(i3:i4) // '_diff.plt'
+ OPEN(lout,file=filename,status='unknown',blank='null')
+ WRITE(lout,'(3A)') 'title = "', project(i1:i2) // '_' // &
+ snumber(i3:i4), '"'
+ ELSE
+ filename = project(i1:i2) // project_sfx(ismpl) (i1s:i2s) // &
+ '_' // snumber(i3:i4) // '.plt'
+ OPEN(lout,file=filename,status='unknown',blank='null')
+ WRITE(lout,'(3A)') 'title = "', project(i1:i2) // &
+ project_sfx(ismpl) (i1s:i2s) // '_' // snumber(i3:i4), '"'
+ END IF
+
+ IF (linfos(3)>=1) THEN
+ WRITE(*,'(3A)') ' [W] : Diffs in Tecplot to "', &
+ filename(1:lblank(filename)), '"'
+ END IF
+
+ WRITE(lout,'(3A)') &
+ 'variables = "x", "y", "z","uindex","i","j","k",', &
+ ' "head", "temp",', &
+ ' "pres"'
+
+! use sline for ZONE string
+ i1 = locstr(project_sfx(ismpl),'_time_')
+ i2 = locstr(project_sfx(ismpl),'_out')
+ IF (i1>=1 .AND. i2>=1) THEN
+ WRITE(sline,'(1A,1I7,3A,1I7)') 'zone T="', ident, &
+ '.time step", SolutionTime=', project_sfx(ismpl) (i1+6:i2- &
+ 1), ', StrandID=', ident
+ WRITE(lout,'(1A,3(A,I5),1A)') sline(1:clast(sline)), &
+ ', i=', i0, ', j=', j0, ', k=', k0, ', f=point'
+ ELSE
+ WRITE(lout,'(3(A,I5),1A)') 'zone i=', i0, ', j=', j0, &
+ ', k=', k0, ', f=point'
+ END IF
+
+! output of box-Centred data:
+ dz = 0.5D0*delz(1)
+ DO k = 1, k0
+ IF (k>1) dz = dz + 0.5D0*(delz(k-1)+delz(k))
+ dy = 0.5D0*dely(1)
+ DO j = 1, j0
+ IF (j>1) dy = dy + 0.5D0*(dely(j-1)+dely(j))
+ dx = 0.5D0*delx(1)
+ DO i = 1, i0
+ IF (i>1) dx = dx + 0.5D0*(delx(i-1)+delx(i))
+ idx = i + (j-1)*i0 + (k-1)*i0*j0
+ WRITE(lout,'(3(e15.6,1x),1I9,3I6,9999(e21.12,1x))') dx, &
+ dy, dz, uindex(i,j,k), i, j, k, &
+ head(i,j,k,ismpl) - headold(idx,cgen_fw,ismpl), &
+ temp(i,j,k,ismpl) - tempold(idx,cgen_fw,ismpl), &
+ (conc(i,j,k,l,ismpl)-concold(idx,l,cgen_fw,ismpl),l=1,ntrans), &
+ (pres(i,j,k,ismpl)-presold(idx,cgen_fw,ismpl))*pa_conv1
+ END DO
+ END DO
+ END DO
+
+ CLOSE(lout)
+ CALL omp_del_file_handler(lout)
+ CALL compress_file(compress_out,filename)
+ RETURN
+ END
diff --git a/forward/output/write_tecplot.f90 b/forward/output/write_tecplot.f90
new file mode 100644
index 0000000..34c2d81
--- /dev/null
+++ b/forward/output/write_tecplot.f90
@@ -0,0 +1,737 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief writes data in tecplot-format
+!> @param[in] ident index number for file name
+!> @param[in] ismpl local sample index
+ SUBROUTINE write_tecplot(ident,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_data
+ use mod_time
+ use mod_flow
+ use mod_temp
+ use mod_linfos
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+ INCLUDE 'OMP_TOOLS.inc'
+
+ INTEGER i1, i2, i3, i4, i1s, i2s, ident, lblank, lout, locstr, &
+ clast
+ EXTERNAL lblank, locstr, clast
+
+ DOUBLE PRECISION vxc, vyc, vzc, kx, ky, kz, lx, ly, lz, por, &
+ rhof, visf
+ EXTERNAL vxc, vyc, vzc, kx, ky, kz, lx, ly, lz, por, rhof, &
+ visf
+ DOUBLE PRECISION qxc, qyc, qzc
+ EXTERNAL qxc, qyc, qzc
+
+ DOUBLE PRECISION px, py, pz
+ character (len=256) :: filename
+ character (len=20) :: snumber
+ character (len=1024) :: sline
+
+ double precision, parameter :: zero = 0.0d0
+
+ logical :: cell_centered
+ integer :: line_break_cc
+
+ IF ( .NOT. tec_out) RETURN
+#ifdef NOPLT
+ RETURN
+#endif
+
+! get his own file discriptor index
+ CALL omp_new_file_handler(lout,16)
+
+ CALL chln(project,i1,i2)
+ CALL chln(project_sfx(ismpl),i1s,i2s)
+ IF (ident>=0) THEN
+ WRITE(snumber,'(1I7)') ident
+ ELSE IF (ident==-1) THEN
+ WRITE(snumber,'(A20)') 'final'
+ ELSE IF (ident==-2) THEN
+ WRITE(snumber,'(A20)') 'debug'
+ ELSE IF (ident==-3) THEN
+ WRITE(snumber,'(A20)') 'ens_mean'
+ ELSE IF (ident==-4) THEN
+ WRITE(snumber,'(A20)') 'mean'
+ ELSE IF (ident==-5) THEN
+ WRITE(snumber,'(A20)') 'ens_mean'
+ END IF
+ CALL chln(snumber,i3,i4)
+
+ IF (i1s==0) THEN
+ filename = project(i1:i2) // '_' // snumber(i3:i4) // '.plt'
+ OPEN(lout,file=filename,status='unknown',blank='null')
+ WRITE(lout,'(3A)') 'title = "', project(i1:i2) // '_' // &
+ snumber(i3:i4), '"'
+ ELSE
+ filename = project(i1:i2) // project_sfx(ismpl) (i1s:i2s) // &
+ '_' // snumber(i3:i4) // '.plt'
+ OPEN(lout,file=filename,status='unknown',blank='null')
+ WRITE(lout,'(3A)') 'title = "', project(i1:i2) // &
+ project_sfx(ismpl) (i1s:i2s) // '_' // snumber(i3:i4), '"'
+ END IF
+
+ IF (linfos(3)>=1) THEN
+ WRITE(*,'(3A)') ' [W] : Tecplot to "', &
+ filename(1:lblank(filename)), '"'
+ END IF
+
+
+ cell_centered = .false.
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ if(cell_centered) then
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ WRITE(lout,'(10A)') 'variables = "xnode","ynode","znode","i", "j", "k", "x", &
+ & "y", "z", "uindex",', &
+ ' "obsz","obst","cindex",', &
+ ' "head", "temp",', &
+ ' "pres",', &
+ ' "vx", "vy", "vz",', &
+ ' "por", "kx", "ky",', &
+ ' "kz", "lx", "ly",', &
+ ' "lz", "rhof", "visf",', &
+ ' "qxc", "qyc", "qzc",', &
+ ' "sigma", "lc", "src",'
+
+
+ ! DIFFERENCE FOR CELLCENTERED
+ i1 = locstr(project_sfx(ismpl),'_time_')
+ i2 = locstr(project_sfx(ismpl),'_out')
+ IF (i1>=1 .AND. i2>=1) THEN
+ WRITE(sline,'(1A,1I7,3A,1I7)') 'zone T="', ident, &
+ '.time step", SolutionTime=', project_sfx(ismpl) (i1+6:i2- &
+ 1), ', StrandID=', ident
+ WRITE(lout,'(1A,3(A,I5),1A)') sline(1:clast(sline)), &
+ ', i=', i0+1, ', j=', j0+1, ', k=', k0+1, ', f=block'
+ ELSE
+ WRITE(lout,'(3(A,I5),1A)') 'zone i=', i0+1, ', j=', j0+1, &
+ ', k=', k0+1, ', f=block'
+ END IF
+
+ ! DIFFERENCE FOR CELLCENTERED
+ write(lout,*) 'VARLOCATION=([1,2,3]=NODAL,&
+ & [4,5,6,7,8,9,10,11,12,13,14,15,16,17&
+ &,18,19,20,21,22,23,24,25,26,27,28,29,&
+ &30,31,32,33,34,35,36,37,38,39]=CELLCENTERED)'
+ line_break_cc = 0
+ do k = 1, k0+1
+ do j = 1, j0+1
+ do i = 1, i0
+ write(unit = lout, fmt = '(g15.6,1x)', advance='no') delxa(i)-0.5d0*delx(i)
+ if(i==i0) write(unit = lout, fmt = '(g15.6,1x)', advance='no') delxa(i)+0.5d0*delx(i)
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end do
+ end do
+ line_break_cc = 0
+ write(unit = lout, fmt = *)
+ do k = 1, k0+1
+ do j = 1, j0
+ do i = 1, i0+1
+ write(unit = lout, fmt = '(g15.6,1x)', advance='no') delya(j)- 0.5d0*dely(j)
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ if(j==j0) then
+ do i = 1, i0+1
+ write(unit = lout, fmt = '(g15.6,1x)', advance='no') delya(j)+0.5d0*dely(j)
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end if
+ end do
+ end do
+ line_break_cc = 0
+ write(unit = lout, fmt = *)
+ do k = 1, k0
+ do j = 1, j0+1
+ do i = 1, i0+1
+ write(unit = lout, fmt = '(g15.6,1x)', advance='no') delza(k)-0.5d0*delz(k)
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end do
+ if(k==k0) then
+ do j = 1, j0+1
+ do i = 1, i0+1
+ write(unit = lout, fmt = '(g15.6,1x)', advance='no') delza(k)+0.5d0*delz(k)
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end do
+ end if
+ end do
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ write(unit = lout, fmt = *)
+ write(unit = lout, fmt = *)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ line_break_cc = 0
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ write(unit = lout, fmt = '(i6)', advance='no') i
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end do
+ end do
+
+ line_break_cc = 0
+ write(unit = lout, fmt = *)
+
+
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ write(unit = lout, fmt = '(i6)', advance='no') j
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end do
+ end do
+
+ line_break_cc = 0
+ write(unit = lout, fmt = *)
+
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ write(unit = lout, fmt = '(i6)', advance='no') k
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end do
+ end do
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ write(unit = lout, fmt = *)
+ write(unit = lout, fmt = *)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ line_break_cc = 0
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ write(unit = lout, fmt = '(g15.6,1x)', advance='no') delxa(i)
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end do
+ end do
+
+ line_break_cc = 0
+ write(unit = lout, fmt = *)
+
+
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ write(unit = lout, fmt = '(g15.6,1x)', advance='no') delya(j)
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end do
+ end do
+
+ line_break_cc = 0
+ write(unit = lout, fmt = *)
+
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ write(unit = lout, fmt = '(g15.6,1x)', advance='no') delza(k)
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end do
+ end do
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ write(unit = lout, fmt = *)
+ write(unit = lout, fmt = *)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ line_break_cc = 0
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ write(unit = lout, fmt = '(i10)', advance='no') uindex(i,j,k)
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end do
+ end do
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ write(unit = lout, fmt = *)
+ write(unit = lout, fmt = *)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ line_break_cc = 0
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ write(unit = lout, fmt = '(es17.8,1x)', advance='no') head(i,j,k,ismpl)
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end do
+ end do
+ line_break_cc = 0
+ write(unit = lout, fmt = *)
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ write(unit = lout, fmt = '(es17.8,1x)', advance='no') temp(i,j,k,ismpl)
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end do
+ end do
+ line_break_cc = 0
+ write(unit = lout, fmt = *)
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ write(unit = lout, fmt = '(es17.8,1x)', advance='no') pres(i,j,k,ismpl)*pa_conv1
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end do
+ end do
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ write(unit = lout, fmt = *)
+ write(unit = lout, fmt = *)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ line_break_cc = 0
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ write(unit = lout, fmt = '(es15.6,1x)', advance='no') vxc(i,j,k,ismpl)
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end do
+ end do
+ line_break_cc = 0
+ write(unit = lout, fmt = *)
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ write(unit = lout, fmt = '(es15.6,1x)', advance='no') vyc(i,j,k,ismpl)
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end do
+ end do
+ line_break_cc = 0
+ write(unit = lout, fmt = *)
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ write(unit = lout, fmt = '(es15.6,1x)', advance='no') vzc(i,j,k,ismpl)
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end do
+ end do
+ line_break_cc = 0
+ write(unit = lout, fmt = *)
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ write(unit = lout, fmt = '(es15.6,1x)', advance='no') por(i,j,k,ismpl)
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end do
+ end do
+ line_break_cc = 0
+ write(unit = lout, fmt = *)
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ px = kx(i,j,k,ismpl)
+ if(klogflag) then
+ px = log10(kx(i,j,k,ismpl))
+ end if
+ write(unit = lout, fmt = '(es15.6,1x)', advance='no') px
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end do
+ end do
+ line_break_cc = 0
+ write(unit = *, fmt = *)
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ py = ky(i,j,k,ismpl)
+ if(klogflag) then
+ py = log10(ky(i,j,k,ismpl))
+ end if
+ write(unit = lout, fmt = '(es15.6,1x)', advance='no') py
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end do
+ end do
+ line_break_cc = 0
+ write(unit = *, fmt = *)
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ pz = kz(i,j,k,ismpl)
+ if(klogflag) then
+ pz = log10(kz(i,j,k,ismpl))
+ end if
+ write(unit = lout, fmt = '(es15.6,1x)', advance='no') pz
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end do
+ end do
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ write(unit = lout, fmt = *)
+ write(unit = lout, fmt = *)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ line_break_cc = 0
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ write(unit = lout, fmt = '(es15.6,1x)', advance='no') lx(i,j,k,ismpl)
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end do
+ end do
+ line_break_cc = 0
+ write(unit = lout, fmt = *)
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ write(unit = lout, fmt = '(es15.6,1x)', advance='no') ly(i,j,k,ismpl)
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end do
+ end do
+ line_break_cc = 0
+ write(unit = lout, fmt = *)
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ write(unit = lout, fmt = '(es15.6,1x)', advance='no') lz(i,j,k,ismpl)
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end do
+ end do
+ line_break_cc = 0
+ write(unit = lout, fmt = *)
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ write(unit = lout, fmt = '(es15.6,1x)', advance='no') rhof(i,j,k,ismpl)
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end do
+ end do
+ line_break_cc = 0
+ write(unit = lout, fmt = *)
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ write(unit = lout, fmt = '(es15.6,1x)', advance='no') visf(i,j,k,ismpl)
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end do
+ end do
+ write(unit = lout, fmt = *)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ write(unit = lout, fmt = *)
+ write(unit = lout, fmt = *)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ line_break_cc = 0
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ write(unit = lout, fmt = '(es15.6,1x)', advance='no') qxc(i,j,k,ismpl)
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end do
+ end do
+ line_break_cc = 0
+ write(unit = lout, fmt = *)
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ write(unit = lout, fmt = '(es15.6,1x)', advance='no') qyc(i,j,k,ismpl)
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end do
+ end do
+ line_break_cc = 0
+ write(unit = lout, fmt = *)
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ write(unit = lout, fmt = '(es15.6,1x)', advance='no') qzc(i,j,k,ismpl)
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end do
+ end do
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ write(unit = lout, fmt = *)
+ write(unit = lout, fmt = *)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ line_break_cc = 0
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ write(unit = lout, fmt = '(es15.6,1x)', advance='no') w(i,j,k,ismpl)
+ ! Line break after 100 entries
+ line_break_cc = line_break_cc + 1
+ if(line_break_cc >= 100) then
+ write(unit = lout, fmt = *)
+ line_break_cc = 0
+ end if
+ end do
+ end do
+ end do
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ else
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+ WRITE(lout,'(9A)') 'variables = "i", "j", "k", "x", &
+ & "y", "z", "uindex",', &
+ ' "head", "temp",', &
+ ' "pres",', &
+ ' "vx", "vy", "vz",', &
+ ' "por", "kx", "ky",', &
+ ' "kz", "lx", "ly",', &
+ ' "lz", "rhof", "visf",', &
+ ' "qxc", "qyc", "qzc",', &
+ ' "sigma", "lc", "src",'
+
+ ! use sline for ZONE string
+ i1 = locstr(project_sfx(ismpl),'_time_')
+ i2 = locstr(project_sfx(ismpl),'_out')
+ IF (i1>=1 .AND. i2>=1) THEN
+!!$ WRITE(sline,'(1A,1I7,3A,1I7)') 'zone T="', ident, &
+!!$ '.time step", SolutionTime=', project_sfx(ismpl) (i1+6:i2- &
+!!$ 1), ', StrandID=', 1
+ WRITE(sline,'(1A,1I7)') 'zone StrandID=', 1
+ WRITE(lout,'(1A,3(A,I5),1A)') sline(1:clast(sline)), &
+ ', i=', i0, ', j=', j0, ', k=', k0, ', f=point'
+ ELSE
+ WRITE(lout,'(3(A,I5),1A)') 'zone i=', i0, ', j=', j0, &
+ ', k=', k0, ', f=point'
+ END IF
+
+ ! output of box-Centred data:
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ px = kx(i,j,k,ismpl)
+ py = ky(i,j,k,ismpl)
+ pz = kz(i,j,k,ismpl)
+ IF (klogflag) THEN
+ px = log10(kx(i,j,k,ismpl))
+ py = log10(ky(i,j,k,ismpl))
+ pz = log10(kz(i,j,k,ismpl))
+ END IF
+ WRITE(lout, &
+ '(3i6,3(g15.6,1x),i10,3(e17.8,1x),19(e15.6,1x))') &
+ i, j, k, delxa(i), delya(j), delza(k), uindex(i,j,k), &
+ head(i,j,k,ismpl), temp(i,j,k,ismpl), &
+ pres(i,j,k,ismpl)*pa_conv1, &
+ vxc(i,j,k,ismpl), vyc(i,j,k,ismpl), &
+ vzc(i,j,k,ismpl), por(i,j,k,ismpl), px, py, pz, &
+ lx(i,j,k,ismpl), ly(i,j,k,ismpl), lz(i,j,k,ismpl), &
+ rhof(i,j,k,ismpl), visf(i,j,k,ismpl), &
+ qxc(i,j,k,ismpl), qyc(i,j,k,ismpl), qzc(i,j,k,ismpl), &
+ w(i,j,k,ismpl)
+ END DO
+ END DO
+ END DO
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ end if
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ CLOSE(lout)
+ CALL omp_del_file_handler(lout)
+ CALL compress_file(compress_out,filename)
+
+ RETURN
+ END
diff --git a/forward/output/write_tecplotc.f90 b/forward/output/write_tecplotc.f90
new file mode 100644
index 0000000..343e646
--- /dev/null
+++ b/forward/output/write_tecplotc.f90
@@ -0,0 +1,149 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief writess conc-data in tecplot-format
+!> @param[in] ident index number for file name
+!> @param[in] ismpl local sample index
+ SUBROUTINE write_tecplotc(ident,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_data
+ use mod_time
+ use mod_flow
+ use mod_temp
+ use mod_conc
+ use mod_linfos
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k, l
+ INCLUDE 'OMP_TOOLS.inc'
+
+ DOUBLE PRECISION v_abs
+ INTEGER i1, i2, i3, i4, i1s, i2s, ident, lblank, lout, locstr, &
+ clast
+ EXTERNAL lblank, locstr, clast
+
+ DOUBLE PRECISION vxc, vyc, vzc, kx, ky, kz, lx, ly, lz, por, &
+ rhof, visf
+ EXTERNAL vxc, vyc, vzc, kx, ky, kz, lx, ly, lz, por, rhof, &
+ visf
+ DOUBLE PRECISION qxc, qyc, qzc
+ EXTERNAL qxc, qyc, qzc
+
+ character (len=80) :: filename
+ character (len=20) :: snumber
+ character (len=1024) :: sline
+ INTRINSIC dsqrt
+
+
+ IF ( .NOT. tec_out .OR. .NOT. trans_active) RETURN
+#ifdef NOPLT
+ RETURN
+#endif
+
+! get his own file discriptor index
+ CALL omp_new_file_handler(lout,16)
+
+ CALL chln(project,i1,i2)
+ CALL chln(project_sfx(ismpl),i1s,i2s)
+ IF (ident>=0) THEN
+ WRITE(snumber,'(1I7)') ident
+ ELSE IF (ident==-1) THEN
+ WRITE(snumber,'(A20)') 'final'
+ ELSE IF (ident==-2) THEN
+ WRITE(snumber,'(A20)') 'debug'
+ ELSE IF (ident==-3) THEN
+ WRITE(snumber,'(A20)') 'ens_mean'
+ ELSE IF (ident==-4) THEN
+ WRITE(snumber,'(A20)') 'mean'
+ ELSE IF (ident==-5) THEN
+ WRITE(snumber,'(A20)') 'ens_mean'
+ END IF
+ CALL chln(snumber,i3,i4)
+
+ IF (i1s==0) THEN
+ filename = project(i1:i2) // '_' // snumber(i3:i4) // &
+ '_chem.plt'
+ OPEN(lout,file=filename,status='unknown',blank='null')
+ WRITE(lout,'(3A)') 'title = "', project(i1:i2) // '_' // &
+ snumber(i3:i4), '_chem"'
+ ELSE
+ filename = project(i1:i2) // project_sfx(ismpl) (i1s:i2s) // &
+ '_' // snumber(i3:i4) // '_chem.plt'
+ OPEN(lout,file=filename,status='unknown',blank='null')
+ WRITE(lout,'(3A)') 'title = "', project(i1:i2) // &
+ project_sfx(ismpl) (i1s:i2s) // '_' // snumber(i3:i4), '"'
+ END IF
+
+ IF (linfos(3)>=1) THEN
+ WRITE(*,'(3A)') ' [W] : Tecplot to "', &
+ filename(1:lblank(filename)), '"'
+ END IF
+
+
+ WRITE(lout,'(7A,9999(1A12,1I4.4,1A1))') &
+ 'variables = "x", "y", "z","uindex",', &
+ ' "i", "j", "k", ', ' "head",', &
+ ' "temp",', ' "pres",', &
+ ' "v_abs",', &
+ ' "tsal"', (', "conc',i,'"',i=1,ntrans)
+
+! use sline for ZONE string
+ i1 = locstr(project_sfx(ismpl),'_time_')
+ i2 = locstr(project_sfx(ismpl),'_out')
+ IF (i1>=1 .AND. i2>=1) THEN
+ WRITE(sline,'(1A,1I7,3A,1I7)') 'zone T="', ident, &
+ '.time step", SolutionTime=', project_sfx(ismpl) (i1+6:i2- &
+ 1), ', StrandID=', ident
+ WRITE(lout,'(1A,3(A,I5),1A)') sline(1:clast(sline)), &
+ ', i=', i0, ', j=', j0, ', k=', k0, ', f=point'
+ ELSE
+ WRITE(lout,'(3(A,I5),1A)') 'zone i=', i0, ', j=', j0, &
+ ', k=', k0, ', f=point'
+ END IF
+
+! output of box-Centred data:
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ v_abs = dsqrt(vxc(i,j,k,ismpl)*vxc(i,j,k,ismpl)+ &
+ vyc(i,j,k,ismpl)*vyc(i,j,k,ismpl)+ &
+ vzc(i,j,k,ismpl)*vzc(i,j,k,ismpl))
+ WRITE(lout,'(3(g15.6,1x),1I9,3I6,1X,5(e17.8,1x),9999(e17.8,1A))') &
+ delxa(i), delya(j), delza(k), &
+ uindex(i,j,k), i, j, k, &
+ head(i,j,k,ismpl), &
+ temp(i,j,k,ismpl), pres(i,j,k,ismpl)*pa_conv1, &
+ v_abs, tsal(i,j,k,ismpl), &
+ (conc(i,j,k,l,ismpl),' ',l=1,ntrans)
+ END DO
+ END DO
+ END DO
+
+ CLOSE(lout)
+ CALL omp_del_file_handler(lout)
+ CALL compress_file(compress_out,filename)
+
+ RETURN
+ END
diff --git a/forward/output/write_text.f90 b/forward/output/write_text.f90
new file mode 100644
index 0000000..cf8ec8c
--- /dev/null
+++ b/forward/output/write_text.f90
@@ -0,0 +1,180 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief writess data in text-format
+!> @param[in] ident index/iteration number
+!> @param[in] ismpl local sample index
+ SUBROUTINE write_text(ident,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_data
+ use mod_time
+ use mod_flow
+ use mod_temp
+ use mod_conc
+ use mod_linfos
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+
+
+
+
+ INCLUDE 'OMP_TOOLS.inc'
+
+ INTEGER i1, i2, i3, i4, i1s, i2s, ident, lblank, lout, tracer
+ EXTERNAL lblank
+ character (len=80) :: filename
+ character (len=20) :: snumber
+ character (len=32) :: strng
+
+ DOUBLE PRECISION vxc, vyc, vzc
+ EXTERNAL vxc, vyc, vzc
+
+
+ IF ( .NOT. txt_out) RETURN
+#ifdef NOTXT
+ RETURN
+#endif
+
+! get his own file discriptor index
+ CALL omp_new_file_handler(lout,16)
+
+ CALL chln(project,i1,i2)
+ CALL chln(project_sfx(ismpl),i1s,i2s)
+ IF (ident>=0) THEN
+ WRITE(snumber,'(1I7)') ident
+ ELSE IF (ident==-1) THEN
+ WRITE(snumber,'(A20)') 'final'
+ ELSE IF (ident==-2) THEN
+ WRITE(snumber,'(A20)') 'debug'
+ ELSE IF (ident==-3) THEN
+ WRITE(snumber,'(A20)') 'ens_mean'
+ ELSE IF (ident==-4) THEN
+ WRITE(snumber,'(A20)') 'mean'
+ ELSE IF (ident==-5) THEN
+ WRITE(snumber,'(A20)') 'ens_mean'
+ END IF
+ CALL chln(snumber,i3,i4)
+
+ IF (i1s==0) THEN
+ filename = project(i1:i2) // '_' // snumber(i3:i4) // '.txt'
+ OPEN(lout,file=filename,status='unknown',blank='null')
+ WRITE(lout,'(1A)') key_char//' title'
+ WRITE(lout,'(1A)') project(i1:i2) // '_' // snumber(i3:i4)
+ ELSE
+ filename = project(i1:i2) // project_sfx(ismpl) (i1s:i2s) // &
+ '_' // snumber(i3:i4) // '.txt'
+ OPEN(lout,file=filename,status='unknown',blank='null')
+ WRITE(lout,'(1A)') key_char//' title'
+ WRITE(lout,'(1A)') project(i1:i2) // &
+ project_sfx(ismpl) (i1s:i2s) // '_' // snumber(i3:i4)
+ END IF
+
+ IF (linfos(3)>=1) THEN
+ WRITE(*,'(3A)') ' [W] : Text to "', &
+ filename(1:lblank(filename)), '"'
+ END IF
+
+! --------
+ WRITE(lout,'(1A)') key_char//' delx'
+ CALL write_dense3d(delx,i0,1,1,lout,ismpl)
+
+ WRITE(lout,'(1A)') key_char//' dely'
+ CALL write_dense3d(dely,1,j0,1,lout,ismpl)
+
+ WRITE(lout,'(1A)') key_char//' delz'
+ CALL write_dense3d(delz,1,1,k0,lout,ismpl)
+
+! --------
+ WRITE(lout,'(1A)') key_char//' head init'
+ CALL write_dense3d(head(1,1,1,ismpl),i0,j0,k0,lout,ismpl)
+
+ WRITE(lout,'(1A)') key_char//' temp init'
+ CALL write_dense3d(temp(1,1,1,ismpl),i0,j0,k0,lout,ismpl)
+
+ DO i = 1, ntrans
+ WRITE(lout,'(1A,1I4.4,1A)') key_char//' tracer', i, ' init'
+ CALL write_dense3d(conc(1,1,1,i,ismpl),i0,j0,k0,lout,ismpl)
+ END DO
+
+ WRITE(lout,'(1A)') key_char//' pres init'
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ x(i,j,k,ismpl) = pres(i,j,k,ismpl)*pa_conv1
+ END DO
+ END DO
+ END DO
+ CALL write_dense3d(x(1,1,1,ismpl),i0,j0,k0,lout,ismpl)
+
+ IF (trac_active) THEN
+ DO tracer = 1, ntrac
+ WRITE(strng,'(1A,1I4.4)') 'tracer', tracer
+ CALL chln(strng,i1,i2)
+ WRITE(lout,'(3A)') key_char//' ', strng(i1:i2), ' init'
+ CALL write_dense3d(conc(1,1,1,tracer,ismpl),i0,j0,k0,lout, &
+ ismpl)
+ END DO
+ END IF
+
+! --------
+ WRITE(lout,'(1A)') key_char//' vx init'
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ x(i,j,k,ismpl) = vxc(i,j,k,ismpl)
+ END DO
+ END DO
+ END DO
+ CALL write_dense3d(x(1,1,1,ismpl),i0,j0,k0,lout,ismpl)
+
+ WRITE(lout,'(1A)') key_char//' vy init'
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ x(i,j,k,ismpl) = vyc(i,j,k,ismpl)
+ END DO
+ END DO
+ END DO
+ CALL write_dense3d(x(1,1,1,ismpl),i0,j0,k0,lout,ismpl)
+
+ WRITE(lout,'(1A)') key_char//' vz init'
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ x(i,j,k,ismpl) = vzc(i,j,k,ismpl)
+ END DO
+ END DO
+ END DO
+ CALL write_dense3d(x(1,1,1,ismpl),i0,j0,k0,lout,ismpl)
+
+! --------
+ CLOSE(lout)
+ CALL omp_del_file_handler(lout)
+ CALL compress_file(compress_out,filename)
+
+ RETURN
+ END
diff --git a/forward/output/write_vtk.f90 b/forward/output/write_vtk.f90
new file mode 100644
index 0000000..41ae772
--- /dev/null
+++ b/forward/output/write_vtk.f90
@@ -0,0 +1,307 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief writes data in vtk-format
+!> @param[in] ident output file index number
+!> @param[in] ismpl local sample index
+!> @details
+!>writes data in vtk-format \n
+!>see: http://mayavi.sourceforge.net\n
+!> http://www.vtk.org/pdf/file-formats.pdf\n
+ SUBROUTINE write_vtk(ident,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_data
+ use mod_time
+ use mod_flow
+ use mod_temp
+ use mod_conc
+ use mod_linfos
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+
+
+
+
+ INCLUDE 'OMP_TOOLS.inc'
+
+ DOUBLE PRECISION, ALLOCATABLE :: val(:)
+ ! DOUBLE PRECISION dx, dy, dz
+ INTEGER i1s, i2s, i1, i2, i3, i4, species, ident, lblank, lout
+ EXTERNAL lblank
+
+ DOUBLE PRECISION vxc, vyc, vzc, kx, ky, kz, lx, ly, lz, por, &
+ qt, rhof,visf, visn
+ EXTERNAL vxc, vyc, vzc, kx, ky, kz, lx, ly, lz, por, qt, rhof, &
+ visf, visn
+
+ DOUBLE PRECISION qxc, qyc, qzc
+ EXTERNAL qxc, qyc, qzc
+
+ character (len=20) :: snumber
+ character (len=256) :: filename, prname, strng
+
+
+ IF ( .NOT. vtk_out) RETURN
+#ifdef NOVTK
+ RETURN
+#endif
+
+! get his own file discriptor index
+ CALL omp_new_file_handler(lout,16)
+
+ ALLOCATE(val(max(i0,j0,k0)))
+
+ CALL chln(project,i1,i2)
+ CALL chln(project_sfx(ismpl),i1s,i2s)
+ IF (ident>=0) THEN
+ WRITE(snumber,'(I7)') ident
+ ELSE IF (ident==-1) THEN
+ WRITE(snumber,'(A20)') 'final'
+ ELSE IF (ident==-2) THEN
+ WRITE(snumber,'(A20)') 'debug'
+ ELSE IF (ident==-3) THEN
+ WRITE(snumber,'(A20)') 'ens_mean'
+ ELSE IF (ident==-4) THEN
+ WRITE(snumber,'(A20)') 'mean'
+ ELSE IF (ident==-5) THEN
+ WRITE(snumber,'(A20)') 'ens_mean'
+ END IF
+ CALL chln(snumber,i3,i4)
+
+ IF (i1s==0) THEN
+ prname = project(i1:i2) // '_' // snumber(i3:i4)
+ filename = project(i1:i2) // '_' // snumber(i3:i4) // '.vtk'
+ ELSE
+ prname = project(i1:i2) // project_sfx(ismpl) (i1s:i2s) // &
+ '_' // snumber(i3:i4)
+ filename = project(i1:i2) // project_sfx(ismpl) (i1s:i2s) // &
+ '_' // snumber(i3:i4) // '.vtk'
+ END IF
+
+ OPEN(lout,file=filename,status='unknown',blank='null')
+
+ IF (linfos(3)>=1) THEN
+ WRITE(*,'(3A)') ' [W] : VTK to "', &
+ filename(1:lblank(filename)), '"'
+ END IF
+
+! HEADER
+ WRITE(lout,'(a/a/a/a/a,3I7)') '# vtk DataFile Version 2.0', &
+ prname, 'ASCII', 'DATASET RECTILINEAR_GRID', 'DIMENSIONS ', &
+ i0, j0, k0
+ !i0+1, j0+1, k0
+
+
+! X_COORDINATES
+ WRITE(lout,'(a,I7,a)') 'X_COORDINATES ', i0, ' float'
+ val(1) = 0.5D0*delx(1)
+ DO i = 2, i0
+ val(i) = val(i-1) + 0.5D0*(delx(i-1)+delx(i))
+ END DO
+ WRITE(lout,'(100e16.6)') (val(i),i=1,i0)
+
+ !WRITE(lout,'(a,I7,a)') 'X_COORDINATES ', i0+1, ' float'
+ !WRITE(lout,'(100e16.6)') (delxa(i)-0.5d0*delx(i),i=1,i0)
+ !write(unit = lout, fmt = '(e16.6)') delxa(i0) + 0.5d0*delx(i0)
+
+! Y_COORDINATES
+ WRITE(lout,'(a,I7,a)') 'Y_COORDINATES ', j0, ' float'
+ val(1) = 0.5D0*dely(1)
+ DO i = 2, j0
+ val(i) = val(i-1) + 0.5D0*(dely(i-1)+dely(i))
+ END DO
+ WRITE(lout,'(100e16.6)') (val(i),i=1,j0)
+
+ !WRITE(lout,'(a,I7,a)') 'Y_COORDINATES ', j0+1, ' float'
+ !WRITE(lout,'(100e16.6)') (delya(i)-0.5d0*dely(i),i=1,j0)
+ !write(unit = lout, fmt = '(e16.6)') delya(j0) + 0.5d0*dely(j0)
+
+
+! Z_COORDINATES
+ WRITE(lout,'(a,I7,a)') 'Z_COORDINATES ', k0, ' float'
+ val(1) = 0.5D0*delz(1)
+ DO i = 2, k0
+ val(i) = val(i-1) + 0.5D0*(delz(i-1)+delz(i))
+ END DO
+ WRITE(lout,'(100e16.6)') (val(i),i=1,k0)
+
+ !WRITE(lout,'(a,I7,a)') 'Z_COORDINATES ', k0+1, ' float'
+ !WRITE(lout,'(100e16.6)') (delza(i)-0.5d0*delz(i),i=1,k0)
+ !write(unit = lout, fmt = '(e16.6)') delza(k0) + 0.5d0*delz(k0)
+
+ !WRITE(lout,'(a,I7,a)') 'Z_COORDINATES ', k0, ' float'
+ !write(unit = lout, fmt = '(100e16.6)') (delza(i),i=1,k0)
+
+
+ WRITE(lout,'(/a,i8)') 'POINT_DATA', i0*j0*k0
+ !WRITE(lout,'(/a,i8)') 'CELL_DATA', i0*j0*k0
+
+
+ if(out_ijk(cout_uindex)) then
+ WRITE(lout,'(a)') 'SCALARS uindex int 1'
+ WRITE(lout,'(a)') 'LOOKUP_TABLE default'
+ WRITE(lout,'(25I10)') (((uindex(i,j,k),i=1,i0),j=1,j0),k=1,k0)
+ end if
+
+ if(out_prop(idx_por)) then
+ WRITE(lout,'(a)') 'SCALARS por float 1'
+ WRITE(lout,'(a)') 'LOOKUP_TABLE default'
+ WRITE(lout,'(100e16.6)') (((por(i,j,k,ismpl),i=1,i0),j=1,j0),k=1,k0)
+ end if
+
+ IF (temp_active) THEN
+ if(out_pv(pv_temp)) then
+ WRITE(lout,'(a)') 'SCALARS temp float 1'
+ WRITE(lout,'(a)') 'LOOKUP_TABLE default'
+ WRITE(lout,'(100e16.6)') (((temp(i,j,k,ismpl),i=1,i0),j=1,j0),k=1,k0)
+ end if
+ if(out_prop(idx_an_lx)) then
+ WRITE(lout,'(a)') 'SCALARS lx float 1'
+ WRITE(lout,'(a)') 'LOOKUP_TABLE default'
+ WRITE(lout,'(100e16.6)') (((lx(i,j,k,ismpl),i=1,i0),j=1,j0),k=1,k0)
+ end if
+ if(out_prop(idx_an_ly)) then
+ WRITE(lout,'(a)') 'SCALARS ly float 1'
+ WRITE(lout,'(a)') 'LOOKUP_TABLE default'
+ WRITE(lout,'(100e16.6)') (((ly(i,j,k,ismpl),i=1,i0),j=1,j0),k=1,k0)
+ end if
+ if(out_prop(idx_lz)) then
+ WRITE(lout,'(a)') 'SCALARS lz float 1'
+ WRITE(lout,'(a)') 'LOOKUP_TABLE default'
+ WRITE(lout,'(100e16.6)') (((lz(i,j,k,ismpl),i=1,i0),j=1,j0),k=1,k0)
+ end if
+ if(out_prop(idx_q)) then
+ WRITE(lout,'(a)') 'VECTORS q float'
+ WRITE(lout,'(3e16.6)') (((qxc(i,j,k,ismpl),qyc(i,j,k,ismpl),qzc(i,j,k,ismpl),i=1,i0),j=1,j0),k=1,k0)
+ WRITE(lout,'(a)') 'SCALARS h float 1'
+ WRITE(lout,'(a)') 'LOOKUP_TABLE default'
+ WRITE(lout,'(100e16.6)') (((qt(i,j,k,ismpl),i=1,i0),j=1,j0),k=1,k0)
+ end if
+ END IF
+
+ IF (head_active) THEN
+ if(out_pv(pv_head)) then
+ WRITE(lout,'(a)') 'SCALARS head float 1'
+ WRITE(lout,'(a)') 'LOOKUP_TABLE default'
+ WRITE(lout,'(100e16.6)') (((head(i,j,k,ismpl),i=1,i0),j=1,j0),k=1,k0)
+ end if
+ END IF
+ IF (pres_active) THEN
+ if(out_pv(pv_pres)) then
+ WRITE(lout,'(a)') 'SCALARS pres float 1'
+ WRITE(lout,'(a)') 'LOOKUP_TABLE default'
+ WRITE(lout,'(100e16.6)') (((pres(i,j,k,ismpl)*pa_conv1,i=1,i0),j=1,j0),k=1,k0)
+#ifdef pres_base
+ CALL pres2head(1,ismpl)
+ WRITE(lout,'(a)') 'SCALARS head float 1'
+ WRITE(lout,'(a)') 'LOOKUP_TABLE default'
+ WRITE(lout,'(100e16.6)') (((head(i,j,k,ismpl),i=1,i0),j=1,j0),k=1,k0)
+#endif
+ end if
+ END IF
+
+ IF (head_active .OR. pres_active) THEN
+ IF (klogflag) THEN
+ if(out_prop(idx_an_kx)) then
+ WRITE(lout,'(a)') 'SCALARS kx float 1'
+ WRITE(lout,'(a)') 'LOOKUP_TABLE default'
+ WRITE(lout,'(100e16.6)') (((log10(kx(i,j,k,ismpl)),i=1, &
+ i0),j=1,j0),k=1,k0)
+ end if
+ if(out_prop(idx_an_ky)) then
+ WRITE(lout,'(a)') 'SCALARS ky float 1'
+ WRITE(lout,'(a)') 'LOOKUP_TABLE default'
+ WRITE(lout,'(100e16.6)') (((log10(ky(i,j,k,ismpl)),i=1, &
+ i0),j=1,j0),k=1,k0)
+ end if
+ if(out_prop(idx_kz)) then
+ WRITE(lout,'(a)') 'SCALARS kz float 1'
+ WRITE(lout,'(a)') 'LOOKUP_TABLE default'
+ WRITE(lout,'(100e16.6)') (((log10(kz(i,j,k,ismpl)),i=1, &
+ i0),j=1,j0),k=1,k0)
+ end if
+ if(out_ijk(cout_rhof)) then
+ WRITE(lout,'(a)') 'SCALARS rhof float 1'
+ WRITE(lout,'(a)') 'LOOKUP_TABLE default'
+ WRITE(lout,'(100e16.6)') (((rhof(i,j,k,ismpl),i=1, &
+ i0),j=1,j0),k=1,k0)
+ end if
+ ELSE
+ if(out_prop(idx_an_kx)) then
+ WRITE(lout,'(a)') 'SCALARS kx float 1'
+ WRITE(lout,'(a)') 'LOOKUP_TABLE default'
+ WRITE(lout,'(100e16.6)') (((kx(i,j,k,ismpl),i=1, &
+ i0),j=1,j0),k=1,k0)
+ end if
+ if(out_prop(idx_an_ky)) then
+ WRITE(lout,'(a)') 'SCALARS ky float 1'
+ WRITE(lout,'(a)') 'LOOKUP_TABLE default'
+ WRITE(lout,'(100e16.6)') (((ky(i,j,k,ismpl),i=1, &
+ i0),j=1,j0),k=1,k0)
+ end if
+ if(out_prop(idx_kz)) then
+ WRITE(lout,'(a)') 'SCALARS kz float 1'
+ WRITE(lout,'(a)') 'LOOKUP_TABLE default'
+ WRITE(lout,'(100e16.6)') (((kz(i,j,k,ismpl),i=1, &
+ i0),j=1,j0),k=1,k0)
+ end if
+ END IF
+ ! WRITE(lout,'(a)') 'VECTORS v float'
+ ! WRITE(lout,'(3e16.6)') (((vxc(i,j,k,ismpl), &
+ ! vyc(i,j,k,ismpl),vzc(i,j,k,ismpl),i=1, &
+ ! i0),j=1,j0),k=1,k0)
+ END IF
+
+ IF (trac_active) THEN
+ if(out_pv(pv_conc)) then
+ DO species = 1, ntrans
+ WRITE(strng,'(I7)') species
+ CALL chln(strng,i1,i2)
+ WRITE(lout,'(a)') 'SCALARS tracer' // strng(i1:i2) // ' float 1'
+ WRITE(lout,'(a)') 'LOOKUP_TABLE default'
+ WRITE(lout,'(100e16.6)') (((conc(i,j,k,species,ismpl),i=1, &
+ i0),j=1,j0),k=1,k0)
+ END DO
+ end if
+ END IF
+
+ !Supposed to be written behind tracer output
+ IF (head_active .OR. pres_active) THEN
+ WRITE(lout,'(a)') 'VECTORS v float'
+ WRITE(lout,'(3e16.6)') (((vxc(i,j,k,ismpl), &
+ vyc(i,j,k,ismpl),vzc(i,j,k,ismpl),i=1, &
+ i0),j=1,j0),k=1,k0)
+ END IF
+
+ DEALLOCATE(val)
+
+ CLOSE(lout)
+ CALL omp_del_file_handler(lout)
+ CALL compress_file(compress_out,filename)
+
+ RETURN
+ END
diff --git a/forward/pres/calc_pres.f90 b/forward/pres/calc_pres.f90
new file mode 100644
index 0000000..de5e0c2
--- /dev/null
+++ b/forward/pres/calc_pres.f90
@@ -0,0 +1,86 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief top level routine for setup and computing pressure flow
+!> @param[in] ismpl local sample index
+ SUBROUTINE calc_pres(ismpl)
+ use arrays
+ use mod_genrlc
+ use mod_genrl
+ use mod_flow
+ use mod_time
+ use mod_linfos
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i
+ INCLUDE 'OMP_TOOLS.inc'
+ INTEGER ijk
+
+
+ IF (linfos(3)>=2) WRITE(*,*) ' ... calc_pres'
+!
+#ifdef fOMP
+!$OMP parallel num_threads(Tlevel_1)
+!$ call omp_binding(ismpl)
+#endif
+
+ ijk = i0*j0*k0
+! default to mark a non-boundary
+!$OMP master
+ DO i = 1, ijk
+ bc_mask(i,ismpl) = '+'
+ END DO
+!$OMP end master
+! initialize coefficients for sparse solvers
+ CALL omp_set_dval(ijk,0.D0,a(1,1,1,ismpl))
+ CALL omp_set_dval(ijk,0.D0,b(1,1,1,ismpl))
+ CALL omp_set_dval(ijk,0.D0,c(1,1,1,ismpl))
+ CALL omp_set_dval(ijk,0.D0,d(1,1,1,ismpl))
+ CALL omp_set_dval(ijk,0.D0,e(1,1,1,ismpl))
+ CALL omp_set_dval(ijk,0.D0,f(1,1,1,ismpl))
+ CALL omp_set_dval(ijk,0.D0,g(1,1,1,ismpl))
+ CALL omp_set_dval(ijk,0.D0,w(1,1,1,ismpl))
+
+!$OMP barrier
+! calculate coefficients
+ CALL set_pcoef(ismpl)
+! set fluid sources/sinks
+ CALL set_pq(ismpl)
+
+!$OMP barrier
+ CALL set_pcoefrs(ismpl)
+#ifdef fOMP
+!$OMP end parallel
+#endif
+
+! set boundary conditions
+ CALL set_pbc(ismpl)
+
+ IF (linfos(3)>=2) WRITE(*,*) ' ... solve(pres)'
+
+! solve it
+ CALL solve(pv_pres,-1,pres(1,1,1,ismpl),errf,aparf,controlf, &
+ ismpl)
+
+ RETURN
+ END
diff --git a/forward/pres/neumann_pres.f90 b/forward/pres/neumann_pres.f90
new file mode 100644
index 0000000..6873ea4
--- /dev/null
+++ b/forward/pres/neumann_pres.f90
@@ -0,0 +1,203 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief OpenMP wrapper for "omp_neumann_pres"
+!> @param[out] neumann_max neumann criteria
+!> @param[in] ismpl local sample index
+ SUBROUTINE neumann_pres(neumann_max,ismpl)
+ use mod_genrl
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ integer :: ismpl
+ INCLUDE 'OMP_TOOLS.inc'
+ DOUBLE PRECISION neumann_max
+
+#ifdef fOMP
+!$OMP parallel num_threads(Tlevel_1)
+!$ call omp_binding(ismpl)
+#endif
+ CALL omp_neumann_pres(neumann_max,ismpl)
+#ifdef fOMP
+!$OMP end parallel
+#endif
+
+ RETURN
+ END
+
+!> @brief calculate grid neuman numbers (pres)
+!> @param[out] neumann_max maximal neuman number
+!> @param[in] ismpl local sample index
+ SUBROUTINE omp_neumann_pres(neumann_max,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_flow
+ use mod_time
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+
+
+ INTEGER c1, c2, c3
+ DOUBLE PRECISION neumann_maxx, neumann_minx, neumann_avgx, &
+ neumann_maxy, neumann_miny, neumann_avgy, neumann_maxz, &
+ neumann_minz, neumann_avgz, neumann_x, neumann_y, neumann_z, &
+ val, neumann_max, delt, fac, davg
+ DOUBLE PRECISION deltat
+ EXTERNAL deltat
+ DOUBLE PRECISION fi, fj, fk, rhof, visf, por, compf, compm, &
+ pstor
+ EXTERNAL fi, fj, fk, rhof, visf, por, compf, compm, pstor
+
+
+ delt = deltat(simtime(ismpl),ismpl)
+
+ IF ( .NOT. (transient .AND. tr_switch(ismpl))) THEN
+!$OMP master
+ WRITE(*,*) ' neumann-pres: not defined for steady state'
+!$OMP end master
+ RETURN
+ ELSE IF (linfos(3)>=2) THEN
+!$OMP master
+ WRITE(*,*)
+ WRITE(*,'(A,1e16.8)') ' ... neumann-pres: delt/tunit = ', &
+ delt/tunit
+ WRITE(*,*)
+!$OMP end master
+ END IF
+
+
+! val in x
+ c1 = 0
+ neumann_maxx = small
+ neumann_minx = big
+ neumann_avgx = 0.0D0
+!$OMP do schedule(static)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 2, i0 - 1
+ c1 = c1 + 1
+ davg = 0.5D0*(delx(i)+delx(i+1))
+ fac = delt/pstor(i,j,k,ismpl)
+ val = fac*fi(i,j,k,ismpl)/(davg*davg)
+ IF (val>neumann_maxx) neumann_maxx = val
+ IF (val<neumann_minx) neumann_minx = val
+ neumann_avgx = neumann_avgx + val
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+
+! val in y
+ c2 = 0
+ neumann_maxy = small
+ neumann_miny = big
+ neumann_avgy = 0.0D0
+!$OMP do schedule(static)
+ DO k = 1, k0
+ DO j = 2, j0 - 1
+ DO i = 1, i0
+ c2 = c2 + 1
+ davg = 0.5D0*(dely(j)+dely(j+1))
+ fac = delt/pstor(i,j,k,ismpl)
+ val = fac*fj(i,j,k,ismpl)/(davg*davg)
+ IF (val>neumann_maxy) neumann_maxy = val
+ IF (val<neumann_miny) neumann_miny = val
+ neumann_avgy = neumann_avgy + val
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+
+! val in z
+ c3 = 0
+ neumann_maxz = small
+ neumann_minz = big
+ neumann_avgz = 0.0D0
+!$OMP do schedule(static)
+ DO k = 2, k0 - 1
+ DO j = 1, j0
+ DO i = 1, i0
+ c3 = c3 + 1
+ davg = 0.5D0*(delz(k)+delz(k+1))
+ fac = delt/pstor(i,j,k,ismpl)
+ val = fac*fk(i,j,k,ismpl)/(davg*davg)
+ IF (val>neumann_maxz) neumann_maxz = val
+ IF (val<neumann_minz) neumann_minz = val
+ neumann_avgz = neumann_avgz + val
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+
+! compute global sum for all values
+ CALL omp_summe(neumann_maxx,neumann_minx,neumann_avgx, &
+ neumann_maxy,neumann_miny,neumann_avgy,neumann_maxz, &
+ neumann_minz,neumann_avgz,c1,c2,c3,ismpl)
+
+!$OMP master
+ IF (i0>2) THEN
+ neumann_avgx = neumann_avgx/dble(c1)
+ ELSE
+ neumann_maxx = 0.0D0
+ neumann_minx = 0.0D0
+ neumann_avgx = 0.0D0
+ END IF
+ IF (j0>2) THEN
+ neumann_avgy = neumann_avgy/dble(c2)
+ ELSE
+ neumann_maxy = 0.0D0
+ neumann_miny = 0.0D0
+ neumann_avgy = 0.0D0
+ END IF
+ IF (k0>2) THEN
+ neumann_avgz = neumann_avgz/dble(c3)
+ ELSE
+ neumann_maxz = 0.0D0
+ neumann_minz = 0.0D0
+ neumann_avgz = 0.0D0
+ END IF
+
+ neumann_max = max(neumann_maxx,neumann_maxy,neumann_maxz)
+
+ IF (linfos(3)>=2) THEN
+ WRITE(*,*) 'neumann number for pres in x,y,z:'
+ WRITE(*,'(a,1e10.3,a,1e10.3,a,1e10.3)') ' max. : ', &
+ neumann_maxx, ', ', neumann_maxy, ', ', neumann_maxz
+ WRITE(*,'(a,1e10.3,a,1e10.3,a,1e10.3)') ' min. : ', &
+ neumann_minx, ', ', neumann_miny, ', ', neumann_minz
+ WRITE(*,'(a,1e10.3,a,1e10.3,a,1e10.3)') ' avg. : ', &
+ neumann_avgx, ', ', neumann_avgy, ', ', neumann_avgz
+ END IF
+
+ IF (linfos(3)>=1 .AND. neumann_max>0.5D0) THEN
+ WRITE(*,'(a)') '!!!: neumann pres greater than 1/2 :'
+ WRITE(*,'(a,1e12.3,a,1e10.3,a,1e10.3)') 'x: ', &
+ neumann_maxx, 'y: ', neumann_maxy, 'z: ', neumann_maxz
+ WRITE(*,*)
+ END IF
+!$OMP end master
+
+ RETURN
+ END
diff --git a/forward/pres/omp_pres2head.f90 b/forward/pres/omp_pres2head.f90
new file mode 100644
index 0000000..8659b00
--- /dev/null
+++ b/forward/pres/omp_pres2head.f90
@@ -0,0 +1,60 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief head setup
+!> @param[in] init flag: 0-init, 1-normal setup
+!> @param[in] ismpl local sample index
+!> @details
+!> head setup currently disabled\n
+ SUBROUTINE omp_pres2head(init,ismpl)
+ use arrays
+ use mod_flow
+ use mod_genrl
+ use mod_linfos
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+ INCLUDE 'OMP_TOOLS.inc'
+ INTEGER init
+ DOUBLE PRECISION psurf
+
+! presetting for dirichlet boundary conditions to avoid site effects
+ IF (pres_active) THEN
+ CALL set_dpbc(ismpl)
+ CALL set_dtbc(ismpl)
+ psurf = 1.0D5
+!$OMP barrier
+!
+!$OMP do schedule(static) collapse(3)
+ DO i = 1, i0
+ DO j = 1, j0
+ DO k = 1, k0
+ head(i,j,k,ismpl) = (pres(i,j,k,ismpl) - psurf)/(rref*grav) + delza(k)
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+ END IF
+!
+ RETURN
+ END
diff --git a/forward/pres/pbuoy.f90 b/forward/pres/pbuoy.f90
new file mode 100644
index 0000000..4e8b924
--- /dev/null
+++ b/forward/pres/pbuoy.f90
@@ -0,0 +1,105 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculate buoyancy for pressure equation
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return buoyancy for pressure
+!> @details
+!> calculate buoyancy for pressure equation\n
+!> sign convention: negative for positive buoyancy\n
+!> if porosity is 1.E-20, the pressure is set to\
+!> atmospheric pressure
+ DOUBLE PRECISION FUNCTION buoy(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_flow
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION rhav, hh, h0, h1, prod, summ
+ DOUBLE PRECISION rhof, kz, visf, por, rh1, rh2
+ EXTERNAL rhof, kz, visf, por
+
+ buoy = 0.D0
+ IF (por(i,j,k,ismpl).LT.1.E-19) THEN
+ rh1 = 1.29E0
+ ELSE
+ rh1 = rhof(i,j,k,ismpl)
+ END IF
+ IF (por(i,j,k+1,ismpl).LT.1.E-19) THEN
+ rh2 = 1.29E0
+ ELSE
+ rh2 = rhof(i,j,k+1,ismpl)
+ END IF
+ rhav = 0.5D0*(rh1+rh2)
+
+ hh = 0.D0
+ h0 = kz(i,j,k,ismpl)/visf(i,j,k,ismpl)
+ h1 = kz(i,j,k+1,ismpl)/visf(i,j,k+1,ismpl)
+ summ = h0 + h1
+ prod = h0*h1
+ IF (summ>0.D0) hh = 2.0D0*prod/summ
+
+ buoy = hh*grav*rhav
+
+ RETURN
+ END
+
+!> @brief calculate buoyancy for pressure equation
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return buoyancy for pressure
+!> @details
+!> calculate buoyancy for pressure equation\n
+!> sign convention: negative for positive buoyancy\n
+ DOUBLE PRECISION FUNCTION vbuoy(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_flow
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION h0, h1, prod, summ
+ DOUBLE PRECISION rhof, kz, visf, rhav, por
+ EXTERNAL rhof, kz, visf, por
+
+ rhav = 0.5D0*(rhof(i,j,k+1,ismpl)+rhof(i,j,k,ismpl))
+ vbuoy = 0.D0
+ h0 = kz(i,j,k,ismpl)*rhof(i,j,k,ismpl)/visf(i,j,k,ismpl)
+ h1 = kz(i,j,k+1,ismpl)*rhof(i,j,k+1,ismpl)/visf(i,j,k+1,ismpl)
+ summ = h0 + h1
+ prod = h0*h1
+ IF (summ>0.D0) vbuoy = 2.0D0*prod/summ
+ IF (por(i,j,k,ismpl).LT.1.E-19) vbuoy = 1.29E-8/998.
+
+ vbuoy = vbuoy*grav
+! IF (por(i,j,k,ismpl).LT.1.E-19) vbuoy = 0.
+
+ RETURN
+ END
diff --git a/forward/pres/pfluxes.f90 b/forward/pres/pfluxes.f90
new file mode 100644
index 0000000..1faa93b
--- /dev/null
+++ b/forward/pres/pfluxes.f90
@@ -0,0 +1,365 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculate velocities at cell faces
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return x velocity (m/(Pa s))
+ DOUBLE PRECISION FUNCTION vx(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+ DOUBLE PRECISION f1, f2, dif, gi
+ EXTERNAL gi
+
+ vx = 0.D0
+ IF (i0>1 .AND. i<i0) THEN
+ dif = pres(i+1,j,k,ismpl) - pres(i,j,k,ismpl)
+ vx = -gi(i,j,k,ismpl)*dif
+ END IF
+ RETURN
+ END
+
+!> @brief calculate velocities at cell faces
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return y velocity (m/(Pa s))
+ DOUBLE PRECISION FUNCTION vy(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_flow
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION f1, f2, dif, gj
+ EXTERNAL gj
+
+ vy = 0.D0
+ IF (j0>1 .AND. j<j0) THEN
+ dif = pres(i,j+1,k,ismpl) - pres(i,j,k,ismpl)
+ vy = -gj(i,j,k,ismpl)*dif
+ END IF
+ RETURN
+ END
+
+!> @brief calculate velocities at cell faces
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return z velocity (m/(Pa s))
+ DOUBLE PRECISION FUNCTION vz(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_flow
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION f1, f2, dif, gk, vbuoy, por, rhof, rhav
+ EXTERNAL gk, rhof, por
+
+ vz = 0.D0
+ IF (k0>1 .AND. k<k0) THEN
+! rhav = 0.5D0*(rhof(i,j,k+1,ismpl)+rhof(i,j,k,ismpl))&
+! *(delza(k+1 )-delza(k))
+ dif = pres(i,j,k+1,ismpl) - pres(i,j,k,ismpl)
+ IF (por(i,j,k,ismpl).GT.1.E-19) THEN
+ rhav = rhof(i,j,k,ismpl)
+ ELSE
+ rhav = 1.29E0
+ END IF
+ IF (por(i,j,k+1,ismpl).GT.1.E-19) THEN
+ rhav = rhav + rhof(i,j,k+1,ismpl)
+ ELSE
+ rhav = rhav + 1.29E0
+ END IF
+ rhav = 0.5*rhav*(delza(k+1 )-delza(k))
+ dif = dif + rhav*grav
+ vz = -gk(i,j,k,ismpl)*dif! - vbuoy(i,j,k,ismpl)
+ END IF
+
+ RETURN
+ END
+
+!> @brief calculate x-velocities at cell centers
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return x velocity (m/(Pa s))
+ DOUBLE PRECISION FUNCTION vxc(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+ DOUBLE PRECISION vx, amean
+ EXTERNAL vx, amean
+
+ vxc = 0.D0
+ IF (i0<=1) RETURN
+ IF (i>1 .AND. i<i0) THEN
+ vxc = amean(vx(i,j,k,ismpl),vx(i-1,j,k,ismpl))
+ ELSE IF (i==1) THEN
+ vxc = vx(i,j,k,ismpl)
+ ELSE IF (i==i0) THEN
+ vxc = vx(i-1,j,k,ismpl)
+ END IF
+ RETURN
+ END
+
+!> @brief calculate y-velocities at cell centers
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return y velocity (m/(Pa s))
+ DOUBLE PRECISION FUNCTION vyc(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_flow
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION vy, amean
+ EXTERNAL vy, amean
+
+ vyc = 0.D0
+ IF (j0<=1) RETURN
+ IF (j>1 .AND. j<j0) THEN
+ vyc = amean(vy(i,j,k,ismpl),vy(i,j-1,k,ismpl))
+ ELSE IF (j==1) THEN
+ vyc = vy(i,j,k,ismpl)
+ ELSE IF (j==j0) THEN
+ vyc = vy(i,j-1,k,ismpl)
+ END IF
+ RETURN
+ END
+
+!> @brief calculate z-velocities at cell centers
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return z velocity (m/(Pa s))
+ DOUBLE PRECISION FUNCTION vzc(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_flow
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION vz, amean
+ EXTERNAL vz, amean
+
+ vzc = 0.D0
+ IF (k0<=1) RETURN
+ IF (k>1 .AND. k<k0) THEN
+ vzc = amean(vz(i,j,k,ismpl),vz(i,j,k-1,ismpl))
+ ELSE IF (k==1) THEN
+ vzc = vz(i,j,k,ismpl)
+ ELSE IF (k==k0) THEN
+ vzc = vz(i,j,k-1,ismpl)
+ END IF
+ RETURN
+ END
+
+!> @brief average conductivities on cell faces in x direction
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return x conductivity (m/(Pa s))
+ DOUBLE PRECISION FUNCTION fi(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_flow
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION f1, f2, prod, summ, kx, rhof, visf
+ EXTERNAL kx, rhof, visf
+
+ fi = 0.D0
+ IF (i0>1 .AND. i<i0) THEN
+ f1 = kx(i,j,k,ismpl)/visf(i,j,k,ismpl)
+ f2 = kx(i+1,j,k,ismpl)/ &
+ visf(i+1,j,k,ismpl)
+ prod = f1*f2
+ summ = f1*delx(i+1) + f2*delx(i)
+ IF (summ>0.D0) fi = 2.D0*prod/summ
+ END IF
+ RETURN
+ END
+
+!> @brief average conductivities on cell faces in y direction
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return y conductivity (m/(Pa s))
+ DOUBLE PRECISION FUNCTION fj(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_flow
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION f1, f2, prod, summ, ky, rhof, visf
+ EXTERNAL ky, rhof, visf
+
+ fj = 0.D0
+ IF (j0>1 .AND. j<j0) THEN
+ f1 = ky(i,j,k,ismpl)/visf(i,j,k,ismpl)
+ f2 = ky(i,j+1,k,ismpl)/ &
+ visf(i,j+1,k,ismpl)
+ prod = f1*f2
+ summ = f1*dely(j+1) + f2*dely(j)
+ IF (summ>0.D0) fj = 2.D0*prod/summ
+ END IF
+ RETURN
+ END
+
+!> @brief average conductivities on cell faces in z direction
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return z conductivity (m/(Pa s))
+ DOUBLE PRECISION FUNCTION fk(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_flow
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION f1, f2, prod, summ, kz, rhof, visf
+ EXTERNAL kz, rhof, visf
+
+ fk = 0.D0
+ IF (k0>1 .AND. k<k0) THEN
+ f1 = kz(i,j,k,ismpl)/visf(i,j,k,ismpl)
+ f2 = kz(i,j,k+1,ismpl)/ &
+ visf(i,j,k+1,ismpl)
+ prod = f1*f2
+ summ = f1*delz(k+1) + f2*delz(k)
+ IF (summ>0.D0) fk = 2.D0*prod/summ
+ END IF
+ RETURN
+ END
+
+!> @brief average conductivities on cell faces in x direction
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return x conductivity (m/(Pa s))
+ DOUBLE PRECISION FUNCTION gi(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_flow
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION f1, f2, prod, summ, kx, rhof, visf
+ EXTERNAL kx, rhof, visf
+
+ gi = 0.D0
+ IF (i0>1 .AND. i<i0) THEN
+ f1 = kx(i,j,k,ismpl)/visf(i,j,k,ismpl)
+ f2 = kx(i+1,j,k,ismpl)/visf(i+1,j,k,ismpl)
+ prod = f1*f2
+ summ = f1*delx(i+1) + f2*delx(i)
+ IF (summ>0.D0) gi = 2.D0*prod/summ
+ END IF
+ RETURN
+ END
+
+!> @brief average conductivities on cell faces in y direction
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return y conductivity (m/(Pa s))
+ DOUBLE PRECISION FUNCTION gj(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_flow
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION f1, f2, prod, summ, ky, rhof, visf
+ EXTERNAL ky, rhof, visf
+
+ gj = 0.D0
+ IF (j0>1 .AND. j<j0) THEN
+ f1 = ky(i,j,k,ismpl)/visf(i,j,k,ismpl)
+ f2 = ky(i,j+1,k,ismpl)/visf(i,j+1,k,ismpl)
+ prod = f1*f2
+ summ = f1*dely(j+1) + f2*dely(j)
+ IF (summ>0.D0) gj = 2.D0*prod/summ
+ END IF
+ RETURN
+ END
+
+!> @brief average conductivities on cell faces in z direction
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return z conductivity (m/(Pa s))
+ DOUBLE PRECISION FUNCTION gk(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_flow
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION f1, f2, prod, summ, kz, rhof, visf
+ EXTERNAL kz, rhof, visf
+
+ gk = 0.D0
+ IF (k0>1 .AND. k<k0) THEN
+ f1 = kz(i,j,k,ismpl)/visf(i,j,k,ismpl)
+ f2 = kz(i,j,k+1,ismpl)/visf(i,j,k+1,ismpl)
+ prod = f1*f2
+ summ = f1*delz(k+1) + f2*delz(k)
+ IF (summ>0.D0) gk = 2.D0*prod/summ
+ END IF
+ RETURN
+ END
diff --git a/forward/pres/pres2head.f90 b/forward/pres/pres2head.f90
new file mode 100644
index 0000000..50cc336
--- /dev/null
+++ b/forward/pres/pres2head.f90
@@ -0,0 +1,51 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief compute hydraulic head from pressure
+!> @param[in] init flag: 0-init, 1-normal setup
+!> @param[in] ismpl local sample index
+!> @details
+!> parallelisation wrapper for hydraulic head computation
+ SUBROUTINE pres2head(init,ismpl)
+ use mod_linfos
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ integer :: ismpl
+ INCLUDE 'OMP_TOOLS.inc'
+ INTEGER init
+
+ IF (linfos(3)>=2) WRITE(*,'(A,I1,A)') &
+ ' ... hydraulic head (init=', init, ')'
+!
+#ifdef fOMP
+!$OMP parallel num_threads(Tlevel_1)
+!$ call omp_binding(ismpl)
+#endif
+!
+ CALL omp_pres2head(init,ismpl)
+!
+#ifdef fOMP
+!$OMP end parallel
+#endif
+!
+ RETURN
+ END
diff --git a/forward/pres/pstor.f90 b/forward/pres/pstor.f90
new file mode 100644
index 0000000..a57ea2b
--- /dev/null
+++ b/forward/pres/pstor.f90
@@ -0,0 +1,44 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates the bulk storativity
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return bulk storativity
+!> @details
+!> storb(i,j,k,ismpl) calculates the bulk storativity \n
+!> at node(i,j,k).\n
+ DOUBLE PRECISION FUNCTION pstor(i,j,k,ismpl)
+ use arrays
+ use mod_flow
+ IMPLICIT NONE
+
+ INTEGER i, j, k, ismpl
+ DOUBLE PRECISION rhof, compm, compf, por
+ EXTERNAL rhof, compm, compf, por
+
+ pstor = rhof(i,j,k,ismpl)*(compm(i,j,k,ismpl)+por(i,j,k,ismpl) &
+ *compf(i,j,k,ismpl))
+ RETURN
+ END
diff --git a/forward/pres/set_pbc.f90 b/forward/pres/set_pbc.f90
new file mode 100644
index 0000000..e918669
--- /dev/null
+++ b/forward/pres/set_pbc.f90
@@ -0,0 +1,218 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief modify coefficents for the head equation according to the boundary
+!> @param[in] ismpl local sample index
+!> @details
+!> modify coefficents for the head equation according to the boundary conditions\n
+!> coefficients are stored as vectors in the diagonals a-g (d center) and rhs in w.\n
+ SUBROUTINE set_pbc(ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_temp
+ use mod_flow
+ use mod_time
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+ integer :: ib
+ INTEGER bcu, tpbcu, bctype, i_dir
+ DOUBLE PRECISION val, malfa, mbeta
+ INTRINSIC max
+
+
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! dirichlet nodes - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ DO ib = first_flow, last_flow
+ i = ibc_data(ib,cbc_i)
+ j = ibc_data(ib,cbc_j)
+ k = ibc_data(ib,cbc_k)
+ bcu = ibc_data(ib,cbc_bcu)
+ tpbcu = max(ibc_data(ib,cbc_bctp),0)
+ bctype = ibc_data(ib,cbc_bt)
+!aw i_dir = ibc_data(ib,cbc_dir)
+! "dirichlet"?, skip otherwise
+ IF (bctype==bt_diri) THEN
+! discrete values
+ IF (bcu<=0) THEN
+ val = dbc_data(ib,1,ismpl)
+ ELSE
+ val = propunit(bcu,idx_hbc,ismpl)
+ END IF
+
+ IF ((tpbcu>0) .AND. nbctp>0) THEN
+! time-dependent bc: val=ac*val+bc
+! get Alfa and Beta modificators
+ CALL get_tpbcalbe(malfa,mbeta,tpbcu,ismpl)
+! update time dependend modification of the bc-value
+ val = malfa + mbeta*val
+ END IF
+
+ IF (tpbcu>=0) THEN
+#ifdef BCMY
+! D = D+my
+ d(i,j,k,ismpl) = d(i,j,k,ismpl) - dbc_data(ib,2,ismpl)
+ w(i,j,k,ismpl) = w(i,j,k,ismpl) - &
+ dbc_data(ib,2,ismpl)*val
+#else
+! standard boundary condition handling
+ a(i,j,k,ismpl) = 0.0D0
+ b(i,j,k,ismpl) = 0.0D0
+ c(i,j,k,ismpl) = 0.0D0
+ e(i,j,k,ismpl) = 0.0D0
+ f(i,j,k,ismpl) = 0.0D0
+ g(i,j,k,ismpl) = 0.0D0
+ d(i,j,k,ismpl) = 1.0D0
+ w(i,j,k,ismpl) = val
+ pres(i,j,k,ismpl) = val
+! mark as boundary for normalising the lin. system
+ bc_mask(i+(j-1)*i0+(k-1)*i0*j0,ismpl) = '0'
+#endif
+ END IF
+ END IF
+ END DO
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! neumann nodes - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ DO ib = first_flow, last_flow
+ i = ibc_data(ib,cbc_i)
+ j = ibc_data(ib,cbc_j)
+ k = ibc_data(ib,cbc_k)
+ bcu = ibc_data(ib,cbc_bcu)
+ tpbcu = max(ibc_data(ib,cbc_bctp),0)
+ bctype = ibc_data(ib,cbc_bt)
+ i_dir = ibc_data(ib,cbc_dir)
+! "neumann"?, skip otherwise
+ IF (bctype==bt_neum) THEN
+! discrete values
+ IF (bcu<=0) THEN
+ val = dbc_data(ib,1,ismpl)
+ ELSE
+ val = propunit(bcu,idx_hbc,ismpl)
+ END IF
+!
+ IF ((tpbcu>0) .AND. nbctp>0) THEN
+! time-dependent bc: val=ac*val+bc
+! get Alfa and Beta modificators
+ CALL get_tpbcalbe(malfa,mbeta,tpbcu,ismpl)
+! update time dependend modification of the bc-value
+ val = malfa + mbeta*val
+ END IF
+
+ IF (tpbcu>=0) THEN
+ IF ((i_dir==0)) val = val/(delx(i)*dely(j)*delz(k))
+ IF ((i_dir==1) .OR. (i_dir==2)) val = val/delx(i)
+ IF ((i_dir==3) .OR. (i_dir==4)) val = val/dely(j)
+ IF ((i_dir==5) .OR. (i_dir==6)) val = val/delz(k)
+ w(i,j,k,ismpl) = w(i,j,k,ismpl) - val
+ END IF
+ END IF
+! WELLMODEL
+ IF (bctype==bt_neuw) THEN
+! discrete values
+ val = dbc_data(ib,1,ismpl)
+!
+ IF ((tpbcu>0) .AND. nbctp>0) THEN
+! time-dependent bc: val=ac*val+bc
+! get Alfa and Beta modificators
+ CALL get_tpbcalbe(malfa,mbeta,tpbcu,ismpl)
+! update time dependend modification of the bc-value
+ val = malfa + mbeta*val
+ END IF
+
+ IF (tpbcu>=0) THEN
+ IF (i_dir/=0) THEN
+ WRITE(*,'(1A,3I7,1A)') &
+ 'error: well function has to be defined by volume (no direction); i,j,k=[',i,j,k,']!'
+ STOP
+ END IF
+ val = val/(delx(i)*dely(j)*delz(k))
+ w(i,j,k,ismpl) = w(i,j,k,ismpl) - val
+ END IF
+ END IF
+!
+ END DO
+
+ RETURN
+ END
+
+!> @brief modify pres for the head equation according to the boundary
+!> @param[in] ismpl local sample index
+!> @details
+!> modify PRES for the pres equation according to the boundary conditions\n
+ SUBROUTINE set_dpbc(ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_temp
+ use mod_flow
+ use mod_time
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+ integer :: ib
+ INTEGER bcu, tpbcu, bctype
+ DOUBLE PRECISION val, malfa, mbeta
+ INTRINSIC max
+
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! dirichlet nodes - - - - - - - - - - - - - - - - - - - - - - - - - - -
+!$OMP do schedule(static)
+ DO ib = first_flow, last_flow
+ i = ibc_data(ib,cbc_i)
+ j = ibc_data(ib,cbc_j)
+ k = ibc_data(ib,cbc_k)
+ bcu = ibc_data(ib,cbc_bcu)
+ tpbcu = max(ibc_data(ib,cbc_bctp),0)
+ bctype = ibc_data(ib,cbc_bt)
+! "dirichlet"?, skip otherwise
+ IF (bctype==bt_diri) THEN
+! discrete values
+ IF (bcu<=0) THEN
+ val = dbc_data(ib,1,ismpl)
+ ELSE
+ val = propunit(bcu,idx_hbc,ismpl)
+ END IF
+
+ IF ((tpbcu>0) .AND. nbctp>0) THEN
+! time-dependent bc: val=ac*val+bc
+! get Alfa and Beta modificators
+ CALL get_tpbcalbe(malfa,mbeta,tpbcu,ismpl)
+! update time dependend modification of the bc-value
+ val = malfa + mbeta*val
+ END IF
+
+ IF (tpbcu>=0) pres(i,j,k,ismpl) = val
+
+!ae WRITE(*,'(6i4,4x,5g16.7)') i, j, k, bcu, tpbcu, bctype, &
+! val
+ END IF
+ END DO
+!$OMP end do nowait
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ RETURN
+ END
diff --git a/forward/pres/set_pcoef.f90 b/forward/pres/set_pcoef.f90
new file mode 100644
index 0000000..6118d96
--- /dev/null
+++ b/forward/pres/set_pcoef.f90
@@ -0,0 +1,166 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculate coefficents for the head equation
+!> @param[in] ismpl local sample index
+!> @details
+!> calculate coefficents for the head equation\n
+!> coefficients are stored as vectors in the diagonals a-g (d center) and rhs in w.\n
+ SUBROUTINE set_pcoef(ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_flow
+ use mod_time
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+
+
+ DOUBLE PRECISION fi, fj, fk
+ EXTERNAL fi, fj, fk
+
+
+!$OMP master
+ IF (linfos(3)>=2) WRITE(*,*) ' ... fcoef'
+!$OMP end master
+
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+!$OMP do schedule(static) collapse(3)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+
+ IF (i0>1) THEN
+ IF (i<i0) THEN
+ e(i,j,k,ismpl) = fi(i,j,k,ismpl)/delx(i)
+ END IF
+ IF (i>1) THEN
+ c(i,j,k,ismpl) = fi(i-1,j,k,ismpl)/delx(i)
+ END IF
+ END IF
+
+ IF (j0>1) THEN
+ IF (j<j0) THEN
+ f(i,j,k,ismpl) = fj(i,j,k,ismpl)/dely(j)
+ END IF
+ IF (j>1) THEN
+ b(i,j,k,ismpl) = fj(i,j-1,k,ismpl)/dely(j)
+ END IF
+ END IF
+
+ IF (k0>1) THEN
+ IF (k<k0) THEN
+ g(i,j,k,ismpl) = fk(i,j,k,ismpl)/delz(k)
+ END IF
+ IF (k>1) THEN
+ a(i,j,k,ismpl) = fk(i,j,k-1,ismpl)/delz(k)
+ END IF
+ END IF
+
+ d(i,j,k,ismpl) = -(e(i,j,k,ismpl)+c(i,j,k,ismpl)+f(i,j,k &
+ ,ismpl)+b(i,j,k,ismpl)+g(i,j,k,ismpl)+a(i,j,k,ismpl))
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+
+ RETURN
+ END
+
+!> @brief calculate right hand side for the head equation
+!> @param[in] ismpl local sample index
+!> @details
+!> calculate right hand side for the head equation\n
+!> coefficients are stored as vectors in the diagonals a-g (d center) and rhs in w.\n
+ SUBROUTINE set_pcoefrs(ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_flow
+ use mod_time
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+
+ DOUBLE PRECISION src, deltf, sijk
+ DOUBLE PRECISION buoy, compf, compm, rhof, por, deltat, pstor, &
+ visf
+ EXTERNAL buoy, compf, compm, rhof, por, deltat, pstor, visf
+
+ deltf = deltat(simtime(ismpl),ismpl)
+! rhs: sources
+ IF (transient .AND. tr_switch(ismpl)) THEN
+! - - - - - - - - transient - - - - - - - - - - -
+ CALL omp_mvp(i0,j0,k0,presold(1,cgen_time,ismpl), &
+ x(1,1,1,ismpl),a(1,1,1,ismpl),b(1,1,1,ismpl), &
+ c(1,1,1,ismpl),d(1,1,1,ismpl),e(1,1,1,ismpl), &
+ f(1,1,1,ismpl),g(1,1,1,ismpl))
+
+!$OMP do schedule(static) collapse(3)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ src = 0.0D0
+! buoyancy
+ IF (k<k0) src = src + buoy(i,j,k,ismpl)/delz(k)
+ !IF (k.eq.k0) src = src + buoy(i,j,k-1,ismpl)/delz(k)
+ IF (k>1) src = src - buoy(i,j,k-1,ismpl)/delz(k)
+ !IF (k.eq.1) src = src - buoy(i,j,k,ismpl)/delz(k)
+
+ sijk = pstor(i,j,k,ismpl)
+ d(i,j,k,ismpl) = d(i,j,k,ismpl) - sijk/(deltf*thetaf)
+ w(i,j,k,ismpl) = w(i,j,k,ismpl) - &
+ (1.0D0-thetaf)*x(i,j,k,ismpl) - &
+ sijk*presold(i+(j-1)*i0+(k-1)*i0*j0,cgen_time,ismpl) &
+ /deltf - src
+ w(i,j,k,ismpl) = w(i,j,k,ismpl)/thetaf
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+
+ ELSE
+! - - - - - - - - steady state - - - - - - - - - - - - - - - - - - - - -
+!$OMP do schedule(static) collapse(3)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ src = 0.0D0
+! buoyancy - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ IF (k<k0) src = src + buoy(i,j,k,ismpl)/delz(k)
+ !IF (k.eq.k0) src = src + buoy(i,j,k-1,ismpl)/delz(k)
+ IF (k>1) src = src - buoy(i,j,k-1,ismpl)/delz(k)
+ !IF (k.eq.1) src = src - buoy(i,j,k,ismpl)/delz(k)
+ w(i,j,k,ismpl) = w(i,j,k,ismpl) - src
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+ END IF
+
+ RETURN
+ END
diff --git a/forward/pres/set_pq.f90 b/forward/pres/set_pq.f90
new file mode 100644
index 0000000..0ad01b5
--- /dev/null
+++ b/forward/pres/set_pq.f90
@@ -0,0 +1,64 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief modify coefficents for the pres equation according to the prescribed sources and sinks
+!> @param[in] ismpl local sample index
+!> @details
+!> modify coefficents for the pres equation according to the prescribed sources and sinks\n
+!> coefficients are stored as vectors in the diagonals a-g (d center) and rhs in w.\n
+ SUBROUTINE set_pq(ismpl)
+ use arrays
+ use mod_genrl
+ use mod_time
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION deltat, deltf, qf
+ EXTERNAL deltat, qf
+
+! rhs: sources
+ IF (transient .AND. tr_switch(ismpl)) THEN
+ deltf = deltat(simtime(ismpl),ismpl)
+!$OMP do schedule(static) collapse(3)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ w(i,j,k,ismpl) = w(i,j,k,ismpl) - qf(i,j,k,ismpl)
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+ ELSE
+!$OMP do schedule(static) collapse(3)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ w(i,j,k,ismpl) = w(i,j,k,ismpl) - qf(i,j,k,ismpl)
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+ END IF
+!
+ RETURN
+ END
diff --git a/forward/save_data.f90 b/forward/save_data.f90
new file mode 100644
index 0000000..329354b
--- /dev/null
+++ b/forward/save_data.f90
@@ -0,0 +1,152 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief Save simulated variable values for later comparison with input data
+!> @param[in] ismpl local sample index
+!> @details
+!> Set the values of sdata from computed (example: head) and old
+!> variable arrays (example: headold). \n
+!> sdata will be compared to the read in values in ddata. \n\n
+!>
+!> Two linear interpolations of the values are implemented:\n
+!> 1. A linear interpolation of the position of the data (px,py,pz)
+!> inside the grid
+!> 2. according to how the time specified for the data
+!> (ddata(l,cdd_time)) is located between the previous simulation
+!> time (simtime(ismpl)) and the current simulation time
+!> (simtime(ismpl)+deltt). \n\n
+!>
+!> collect and save the computed values for a comparison with
+!> 'ddata(:,cid_pv)'\n
+!> -> usage in 'write_data.f' and 'forward/j_*-array(inversion)'\n
+ SUBROUTINE save_data(ismpl)
+
+ use arrays
+ use mod_genrl
+ use mod_data
+ use mod_time
+ use mod_linfos
+
+ IMPLICIT NONE
+
+ integer :: ismpl
+ integer :: i, j, k, l
+
+ DOUBLE PRECISION deltt, deltat, numdiff, dalfa, dbeta, interpolatelin, bhpr
+ DOUBLE PRECISION px, py, pz, vals, vals_old
+
+ INTEGER i_type, i_si
+
+ EXTERNAL deltat, interpolatelin, bhpr
+
+ ! get current time step, set 1.0d0 for steady state
+ deltt = deltat(simtime(ismpl),ismpl)
+ IF ( .NOT. transient) deltt = 1.D0
+
+! allowed numerical difference
+ numdiff = 1.0D2*const_dble(1)*simtime(ismpl)
+!
+ DO l = 1, ndata
+
+! correct time interval, or steady-state
+ IF (ddata(l,cdd_time)>simtime(ismpl)+numdiff .AND. &
+ ddata(l,cdd_time)<=simtime(ismpl)+deltt+numdiff .OR. &
+ .NOT. transient) THEN
+
+ i = idata(l,cid_i)
+ j = idata(l,cid_j)
+ k = idata(l,cid_k)
+ px = ddata(l,cdd_i)
+ py = ddata(l,cdd_j)
+ pz = ddata(l,cdd_k)
+
+ i_type = idata(l,cid_pv)
+ i_si = idata(l,cid_si)
+
+! interpolation: m=(a*n+b*o)/(a+b)
+ dalfa = ddata(l,cdd_time) - simtime(ismpl)
+ dbeta = deltt - dalfa
+ IF ( .NOT. transient) THEN
+ dalfa = 1.D0
+ dbeta = 0.D0
+ END IF
+
+ vals = 0.0D0
+ vals_old = 0.0D0
+
+! choose physical value to save
+ IF (i_type==pv_head) THEN
+
+ vals = interpolatelin(i0,j0,k0, i,j,k, &
+ head(1,1,1,ismpl), &
+ px,py,pz, delx,dely,delz, delxa,delya,delza)
+
+ vals_old = interpolatelin(i0,j0,k0, i,j,k, &
+ headold(1,cgen_time,ismpl), &
+ px,py,pz, delx,dely,delz, delxa,delya,delza)
+
+ ELSE IF (i_type==pv_pres) THEN
+
+ vals = interpolatelin(i0,j0,k0, i,j,k, &
+ pres(1,1,1,ismpl), &
+ px,py,pz, delx,dely,delz, delxa,delya,delza)
+
+ vals_old = interpolatelin(i0,j0,k0, i,j,k, &
+ presold(1,cgen_time,ismpl), &
+ px,py,pz, delx,dely,delz, delxa,delya,delza)
+
+ ELSE IF (i_type==pv_temp) THEN
+
+ vals = interpolatelin(i0,j0,k0, i,j,k, &
+ temp(1,1,1,ismpl), &
+ px,py,pz, delx,dely,delz, delxa,delya,delza)
+
+ vals_old = interpolatelin(i0,j0,k0, i,j,k, &
+ tempold(1,cgen_time,ismpl), &
+ px,py,pz, delx,dely,delz, delxa,delya,delza)
+
+ ELSE IF (i_type==pv_conc) THEN
+
+ vals = interpolatelin(i0,j0,k0, i,j,k, &
+ conc(1,1,1,i_si,ismpl), &
+ px,py,pz, delx,dely,delz, delxa,delya,delza)
+
+ vals_old = interpolatelin(i0,j0,k0, i,j,k, &
+ concold(1,i_si,cgen_time,ismpl), &
+ px,py,pz, delx,dely,delz, delxa,delya,delza)
+
+ ELSE IF (i_type==pv_bhpr) THEN
+
+ vals = bhpr(i,j,k,ismpl)
+ vals_old = vals
+
+ END IF
+
+ ! Write time-interpolated value to sdata
+ sdata(l,ismpl) = (dalfa*vals+dbeta*vals_old)/deltt
+
+ END IF
+
+ END DO
+
+ RETURN
+ END
diff --git a/forward/set_tsal.f90 b/forward/set_tsal.f90
new file mode 100644
index 0000000..62dc15f
--- /dev/null
+++ b/forward/set_tsal.f90
@@ -0,0 +1,82 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief parallelisation wrapper for "omp_set_tsal"
+!> @param[in] ismpl local sample index
+ SUBROUTINE set_tsal(ismpl)
+ use mod_genrl
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ integer :: ismpl
+ INCLUDE 'OMP_TOOLS.inc'
+
+#ifdef fOMP
+!$OMP parallel num_threads(Tlevel_1)
+!$ call omp_binding(ismpl)
+#endif
+ CALL omp_set_tsal(ismpl)
+#ifdef fOMP
+!$OMP end parallel
+#endif
+
+ RETURN
+ END
+
+!> @brief calculate total salinity
+!> @param[in] ismpl local sample index
+!> @details
+!>calculate total salinity\n
+ SUBROUTINE omp_set_tsal(ismpl)
+ use arrays
+ use mod_conc
+ use mod_genrl
+ use mod_genrlc
+ use mod_linfos
+ IMPLICIT NONE
+
+ integer :: ismpl
+ integer :: i, j, k
+ INTEGER species
+ DOUBLE PRECISION summ, fac
+
+!$OMP master
+ IF (linfos(3)>=2) WRITE(*,'(1A)') &
+ ' ... setting total salinity'
+!$OMP end master
+
+!$OMP do schedule(static) collapse(3)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ summ = 0.D0
+ DO species = 1, ntrans
+ fac = mmas_c(species)/mmas_nacl
+ summ = summ + fac*conc(i,j,k,species,ismpl)
+ END DO
+ tsal(i,j,k,ismpl) = summ
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+
+ RETURN
+ END
diff --git a/forward/set_var_deltat.f90 b/forward/set_var_deltat.f90
new file mode 100644
index 0000000..d35d467
--- /dev/null
+++ b/forward/set_var_deltat.f90
@@ -0,0 +1,83 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief Set variable time step size variables delt_count and flag_delt
+!> @param[in] iter_nl nonlinear iteration counter
+!> @param[in] ismpl local sample index
+!> @details
+!> Set variable time step size variables delt_count and flag_delt
+subroutine set_var_deltat(iter_nl, ismpl)
+
+ use arrays, only: delt_count, flag_delt
+ use mod_genrl, only: iter_nlold, maxiter_nl, delt_double, nlconverge
+ use mod_linfos, only: linfos
+
+ implicit none
+
+ ! local sample index
+ integer :: ismpl
+
+ ! nonlinear iteration counter
+ integer, intent (in) :: iter_nl
+
+ ! Set delt_count
+ ! ------------------
+
+ ! Test whether to hasten or prevent time-step doubling
+ IF (iter_nl+iter_nlold.LT.maxiter_nl/2) THEN
+ delt_count(ismpl) = MIN(delt_count(ismpl)+2,delt_double-1)
+ ELSE IF (iter_nl+iter_nlold.LT.maxiter_nl) THEN
+ delt_count(ismpl) = MIN(delt_count(ismpl)+1,delt_double-1)
+ ELSE IF (iter_nl+iter_nlold.GT.maxiter_nl) THEN
+ delt_count(ismpl) = MAX(delt_count(ismpl)-1,0)
+ END IF
+
+ ! Standard output
+ IF (linfos(3)>=2) WRITE (*,*) 'delt_count', delt_count(ismpl), &
+ 'delt_double', delt_double, 'iter_nlold', iter_nlold
+
+ ! Set counter for next iteration
+ iter_nlold = iter_nl/4 + (3*iter_nlold)/4
+
+ ! Set flag_delt
+ ! ------------------
+
+ ! Test if nonlinear iteration reached maximum iteration count
+ IF (((iter_nl.EQ.maxiter_nl).OR.(flag_delt(ismpl).EQ.(-1)))) THEN
+
+ IF (iter_nl.EQ.maxiter_nl .AND. (nlconverge .eq. 0)) THEN
+ WRITE(*,*) "Nonlinear iteration reached maximum iteration ", iter_nl, ". Set flag_delt to -2."
+ END IF
+
+ IF (flag_delt(ismpl).EQ.(-1)) THEN
+ WRITE(*,*) "Iterative Solver reached maximum iteration. Set flag_delt to -2."
+ END IF
+
+ flag_delt(ismpl) = -2
+
+ ELSE IF (flag_delt(ismpl).EQ.0) THEN
+
+ flag_delt(ismpl) = flag_delt(ismpl) + 1
+
+ END IF
+
+end subroutine set_var_deltat
diff --git a/forward/shemach/compress_file.f90 b/forward/shemach/compress_file.f90
new file mode 100644
index 0000000..30e9aa6
--- /dev/null
+++ b/forward/shemach/compress_file.f90
@@ -0,0 +1,45 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief compress a file (to *.bz2, *.zip, *.gz)
+!> @param[in] fname file to compress
+!> @param[in] ctool index number of the compression tool
+ SUBROUTINE compress_file(ctool,fname)
+ use arrays
+ IMPLICIT NONE
+ character (len=*) :: fname
+ INTEGER ctool
+ INTRINSIC trim
+
+! no compression
+ IF (compress_suffix(ctool)=='plain') RETURN
+! bzip2
+ IF (compress_suffix(ctool)=='bz2') CALL system('bzip2 -f -9 "' &
+ //trim(fname)//'"')
+! gnu zip
+ IF (compress_suffix(ctool)=='gz') CALL system('gzip -f -9 "'// &
+ trim(fname)//'"')
+! std. zip
+ IF (compress_suffix(ctool)=='zip') CALL system('zip -m -9 "'// &
+ trim(fname)//'.zip" "'//trim(fname)//'"')
+ RETURN
+ END
diff --git a/forward/shemach/sys_cputime.f90 b/forward/shemach/sys_cputime.f90
new file mode 100644
index 0000000..ba35e51
--- /dev/null
+++ b/forward/shemach/sys_cputime.f90
@@ -0,0 +1,39 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief function wrapper for the current time
+!> @param[out] tsec current time
+ SUBROUTINE sys_cputime(tsec)
+ IMPLICIT NONE
+ DOUBLE PRECISION tsec
+#ifndef fOMP
+ REAL (kind=4) :: ticks
+#endif
+ DOUBLE PRECISION, EXTERNAL :: omp_get_wtime
+#ifdef fOMP
+ tsec = omp_get_wtime()
+#else
+ CALL cpu_time(ticks)
+ tsec = ticks
+#endif
+ RETURN
+ END
diff --git a/forward/shemach/sys_mkdir.f90 b/forward/shemach/sys_mkdir.f90
new file mode 100644
index 0000000..373659c
--- /dev/null
+++ b/forward/shemach/sys_mkdir.f90
@@ -0,0 +1,40 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief creates a directory
+!> @param[in] string directory name
+ SUBROUTINE sys_mkdir(string)
+ IMPLICIT NONE
+!aw integer perm, erro
+ character (len=*) :: string
+ INTRINSIC trim
+
+!aw erro=0
+!aw call MKDIR(strng,perm,erro)
+ CALL system('mkdir '//trim(string))
+!aw if (erro.ne.0) then
+!aw write(*,'(a,i4,a,a,a,i3)')
+!aw & 'error ',erro,' opening file: ',string
+!aw *,' permissions: ',perm
+!aw endif
+ RETURN
+ END
diff --git a/forward/stab_param.f90 b/forward/stab_param.f90
new file mode 100644
index 0000000..1e55165
--- /dev/null
+++ b/forward/stab_param.f90
@@ -0,0 +1,50 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief stabilise paramter (cutting to its limits)
+!> @param[in] value paramter value
+!> @param[in] s_k component index (parameter type)
+!> @param[in] s_u unit index
+ SUBROUTINE stab_param(value,s_k,s_u)
+ use arrays
+ IMPLICIT NONE
+ DOUBLE PRECISION value
+ INTEGER s_k, s_u
+!
+ IF (s_k>nprop_load) THEN
+ WRITE(*,'(1A,2I4,1A)') 'error: component index out of range (component,unit)=', s_k, s_u, '!'
+ STOP
+ END IF
+ IF (s_u>nunits) THEN
+ WRITE(*,'(1A,2I4,1A)') 'error: unit index out of range (component,unit)=', s_k, s_u, '!'
+ STOP
+ END IF
+ IF (value>prop_max(s_k)) THEN
+ WRITE(*,'(3A,1I4.4,1A,2(1e16.8,1A))') 'warning: cut ',properties(s_k),'_unit',s_u,' =',value,' to ',prop_max(s_k),' !'
+ value = prop_max(s_k)
+ END IF
+ IF (value<prop_min(s_k)) THEN
+ WRITE(*,'(3A,1I4.4,1A,2(1e16.8,1A))') 'warning: cut ',properties(s_k),'_unit',s_u,' =',value,' to ',prop_min(s_k),' !'
+ value = prop_min(s_k)
+ END IF
+ RETURN
+ END
diff --git a/forward/static_relaxation.f90 b/forward/static_relaxation.f90
new file mode 100644
index 0000000..50e33ff
--- /dev/null
+++ b/forward/static_relaxation.f90
@@ -0,0 +1,70 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief Compute static relaxation for flow and temperature
+!> @param[in] ijk number of cells
+!> @param[inout] ismpl local sample index
+!> @details
+!> Static relaxation is computed for variable arrays head, pres, temp:
+!> \n\n
+!>
+!> var = (1-theta)*varold + theta*var \n
+subroutine static_relaxation(ijk,ismpl)
+
+ use arrays, only: head, headold, pres, presold, temp, tempold
+ use mod_genrl, only: cgen_time
+ use mod_time, only: thetaf, thetat
+
+ implicit none
+
+ ! local sample index
+ integer :: ismpl
+
+ ! Number of cells
+ integer, intent (in) :: ijk
+
+
+ ! flow
+ if (thetaf /= 1.0d0) then
+
+#ifdef head_base
+ CALL dscal(ijk,thetaf,head(1,1,1,ismpl),1)
+ CALL daxpy(ijk,1.0D0-thetaf,headold(1,cgen_time,ismpl),1,head(1,1,1,ismpl),1)
+#endif
+#ifdef pres_base
+ CALL dscal(ijk,thetaf,pres(1,1,1,ismpl),1)
+ CALL daxpy(ijk,1.0D0-thetaf,presold(1,cgen_time,ismpl),1,pres(1,1,1,ismpl),1)
+#endif
+
+ end if
+
+ ! temperature
+ if (thetat /= 1.0d0) then
+
+ CALL dscal(ijk,thetat,temp(1,1,1,ismpl),1)
+ CALL daxpy(ijk,1.0D0-thetat,tempold(1,cgen_time,ismpl),1,temp(1,1,1,ismpl),1)
+
+ end if
+
+ return
+
+end subroutine static_relaxation
diff --git a/forward/strngut/beginlast.f90 b/forward/strngut/beginlast.f90
new file mode 100644
index 0000000..dc72d6a
--- /dev/null
+++ b/forward/strngut/beginlast.f90
@@ -0,0 +1,45 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief returns the position of the first non-separator character of the last non-seperator block
+!> @param[in] string search string
+!> @return position of the first non-separator character
+!> @details
+!> returns the position of the first non-separator character of the \n
+!> last non-seperator block\n
+ INTEGER FUNCTION beginlast(string)
+ IMPLICIT NONE
+ character (len=*) :: string
+ INTEGER i
+ INTRINSIC achar
+
+ beginlast = 1
+ DO i = len(string), 1, -1
+ IF (string(i:i)==' ' .OR. string(i:i)==',' .OR. &
+ string(i:i)==';' .OR. string(i:i)==':' .OR. &
+ string(i:i)=='=' .OR. string(i:i)==achar(9)) THEN
+ beginlast = i
+ RETURN
+ END IF
+ END DO
+ RETURN
+ END
diff --git a/forward/strngut/cfirst.f90 b/forward/strngut/cfirst.f90
new file mode 100644
index 0000000..e2039a6
--- /dev/null
+++ b/forward/strngut/cfirst.f90
@@ -0,0 +1,42 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief returns the position of the first non-separator character in string
+!> @param[in] string search string
+!> @return position of the first non-separator character
+!> @details
+!> (a modified copy of "lblank")\n
+ INTEGER FUNCTION cfirst(string)
+ IMPLICIT NONE
+ character (len=*) :: string
+ INTRINSIC achar
+
+ DO cfirst = 1, len(string)
+ IF (string(cfirst:cfirst)/=' ' .AND. &
+ string(cfirst:cfirst)/=',' .AND. string(cfirst:cfirst)/= &
+ ';' .AND. string(cfirst:cfirst)/=':' .AND. &
+ string(cfirst:cfirst)/='=' .AND. string(cfirst:cfirst)/= &
+ achar(9)) RETURN
+ END DO
+ cfirst = len(string) + 1
+ RETURN
+ END
diff --git a/forward/strngut/chln.f90 b/forward/strngut/chln.f90
new file mode 100644
index 0000000..b0d5973
--- /dev/null
+++ b/forward/strngut/chln.f90
@@ -0,0 +1,60 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief returns positions of first and last non-blank character
+!> @param[in] text string line
+!> @param[out] ianf first non-blank character
+!> @param[out] iend last non-blank character
+!> @details
+!> returns positions of first and last non-blank character in string\n
+ SUBROUTINE chln(text,ianf,iend)
+ IMPLICIT NONE
+ INTEGER i, j, l, ianf, iend
+ character (len=*) :: text
+ LOGICAL lead, trail
+
+ lead = .TRUE.
+ trail = .TRUE.
+ l = len(text)
+!
+ DO i = 1, l
+ IF (lead .AND. text(i:i)/=' ') THEN
+! first non-blank CharaCter: store ianf
+ ianf = i
+ lead = .FALSE.
+ END IF
+!
+ j = l - i + 1
+ IF (trail .AND. text(j:j)/=' ') THEN
+! last non-blank CharaCter: store iend
+ iend = j
+ trail = .FALSE.
+ END IF
+ IF (( .NOT. lead) .AND. ( .NOT. trail)) RETURN
+ END DO
+!
+! error return, all string blank
+ ianf = 0
+ iend = 0
+!
+ RETURN
+ END
diff --git a/forward/strngut/clast.f90 b/forward/strngut/clast.f90
new file mode 100644
index 0000000..cfa7448
--- /dev/null
+++ b/forward/strngut/clast.f90
@@ -0,0 +1,41 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief returns the position of the last non-separator character in string
+!> @param[in] string search string
+!> @return position of the last non-separator character
+!> @details
+!> (a modified copy of "lblank")\n
+ INTEGER FUNCTION clast(string)
+ IMPLICIT NONE
+ character (len=*) :: string
+ INTRINSIC achar
+
+ DO clast = len(string), 1, -1
+ IF (string(clast:clast)/=' ' .AND. string(clast:clast)/=',' &
+ .AND. string(clast:clast)/=';' .AND. &
+ string(clast:clast)/=':' .AND. string(clast:clast)/='=' &
+ .AND. string(clast:clast)/=achar(9)) RETURN
+ END DO
+ clast = 0
+ RETURN
+ END
diff --git a/forward/strngut/found.f90 b/forward/strngut/found.f90
new file mode 100644
index 0000000..378c289
--- /dev/null
+++ b/forward/strngut/found.f90
@@ -0,0 +1,74 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief locate keyword in file 'ifil', begin at position 1
+!> @param[in] ifil file handler of the opened file
+!> @param[in] key section name
+!> @param[out] block_s current/last readed line from file
+!> @param[in] need_it "true": stop when not found (generate an error for important sections)
+!> @return "true" when section (key) found in file
+ LOGICAL FUNCTION found(ifil,key,block_s,need_it)
+ USE mod_genrl
+ IMPLICIT NONE
+ INTEGER ifil, iwrd, kb, ke
+ character (len=*) :: key, block_s
+ LOGICAL need_it
+
+ INTEGER lblank, locstr
+ EXTERNAL lblank, locstr
+
+ iwrd = 1
+ found = .FALSE.
+
+! search dataset
+ CALL chln(key,kb,ke)
+
+10 CONTINUE
+ READ(ifil,'(a)',end=15,err=15) block_s
+ found = locstr(block_s,key(kb:ke)) == 1
+! no matching, try next (10)
+ IF ( .NOT. found .OR. lblank(block_s)==0 .OR. &
+ block_s(1:1)/=key_char) GO TO 10
+ RETURN
+
+! end of file -> reading file again
+15 CONTINUE
+ REWIND ifil
+
+20 CONTINUE
+ READ(ifil,'(a)',end=25,err=25) block_s
+ found = locstr(block_s,key(kb:ke)) == 1
+! no matching, try next (20)
+ IF ( .NOT. found .OR. lblank(block_s)==0 .OR. &
+ block_s(1:1)/=key_char) GO TO 20
+ RETURN
+
+! end of file -> array not in file
+25 REWIND ifil
+ IF (need_it) THEN
+ WRITE(*,*) 'error: reading field "', key(kb:ke), &
+ '", not found!'
+ STOP
+ END IF
+
+ RETURN
+ END
diff --git a/forward/strngut/get_arg.f90 b/forward/strngut/get_arg.f90
new file mode 100644
index 0000000..ddccf71
--- /dev/null
+++ b/forward/strngut/get_arg.f90
@@ -0,0 +1,51 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief returns the begin and the end of the argument of the key in the line string
+!> @param[in] key search string
+!> @param[in] line current character line (find here the key)
+!> @param[out] first begin index of the argument
+!> @param[out] last end index of the argument
+ SUBROUTINE get_arg(key,line,first,last)
+ IMPLICIT NONE
+ character (len=*) :: key, line
+ INTEGER first, last, locstr, cfirst
+ EXTERNAL locstr, cfirst
+ INTRINSIC achar
+
+ last = 0
+ first = locstr(line,key)
+ IF (first==0) RETURN
+!
+ first = first + len(key)
+ first = first - 1 + cfirst(line(first:len(line)))
+!
+ DO last = first, len(line) - 1
+ IF (line(last+1:last+1)==' ' .OR. line(last+1:last+1)==',' &
+ .OR. line(last+1:last+1)==';' .OR. &
+ line(last+1:last+1)==':' .OR. line(last+1:last+1)=='=' &
+ .OR. line(last+1:last+1)==achar(9)) RETURN
+ END DO
+ last = len(line)
+!
+ RETURN
+ END
diff --git a/forward/strngut/lblank.f90 b/forward/strngut/lblank.f90
new file mode 100644
index 0000000..96e0056
--- /dev/null
+++ b/forward/strngut/lblank.f90
@@ -0,0 +1,41 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief returns the position of the last non-blank character in string
+!> @param[in] string search string
+!> @return position of the last non-blank character
+!> @details
+!> (actually there is a standard unix function of the same name\n
+!> that does the exactly same thing. this is provided for\n
+!> compatibility on non-unix systems.)\n
+ INTEGER FUNCTION lblank(string)
+ IMPLICIT NONE
+ character (len=*) :: string
+ INTRINSIC achar
+
+ DO lblank = len(string), 1, -1
+ IF (string(lblank:lblank)/=' ' .AND. &
+ string(lblank:lblank)/=achar(9)) RETURN
+ END DO
+ lblank = 0
+ RETURN
+ END
diff --git a/forward/strngut/locstr.f90 b/forward/strngut/locstr.f90
new file mode 100644
index 0000000..35a49b6
--- /dev/null
+++ b/forward/strngut/locstr.f90
@@ -0,0 +1,54 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief returns the position of str2 in str1 ignores case
+!> @param[in] str1 string where to find str2
+!> @param[in] str2 search string (key)
+!> @return position of str2 in str1
+!> @details
+!> returns 0 if str2 not found in str1\n
+ INTEGER FUNCTION locstr(str1,str2)
+ IMPLICIT NONE
+ character (len=*) :: str1, str2
+ INTEGER i, j, capdif
+ LOGICAL same
+
+ locstr = 0
+ capdif = ichar('a') - ichar('A')
+!
+ DO i = 1, len(str1) - len(str2) + 1
+ same = .TRUE.
+ DO j = 1, len(str2)
+ same = same .AND. (str1(i+j-1:i+j-1)==str2(j:j) .OR. 'A'<= &
+ str2(j:j) .AND. str2(j:j)<='Z' .AND. ichar(str1(i+j-1:i+ &
+ j-1))==ichar(str2(j:j))+capdif .OR. 'a'<=str2(j:j) .AND. &
+ str2(j:j)<='z' .AND. ichar(str1(i+j-1:i+ &
+ j-1))==ichar(str2(j:j))-capdif)
+ END DO
+ IF (same) THEN
+ locstr = i
+ RETURN
+ END IF
+ END DO
+!
+ RETURN
+ END
diff --git a/forward/strngut/sfirst.f90 b/forward/strngut/sfirst.f90
new file mode 100644
index 0000000..a379b4e
--- /dev/null
+++ b/forward/strngut/sfirst.f90
@@ -0,0 +1,41 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief returns position before the first separator character in string (special version)
+!> @param[in] string search string
+!> @return position before the first separator character
+!> @details
+!> special version for reading extended parameters (used in "no_ext_link")\n
+ INTEGER FUNCTION sfirst(string)
+ IMPLICIT NONE
+ character (len=*) :: string
+ INTEGER i
+ INTRINSIC achar
+
+ sfirst = 0
+ DO i = 1, len(string)
+ IF (string(i:i)==',' .OR. string(i:i)==';' .OR. &
+ string(i:i)==':' .OR. string(i:i)=='=') RETURN
+ IF (string(i:i)/=' ' .AND. string(i:i)/=achar(9)) sfirst = i
+ END DO
+ RETURN
+ END
diff --git a/forward/temp/calc_temp.f90 b/forward/temp/calc_temp.f90
new file mode 100644
index 0000000..df1cfb5
--- /dev/null
+++ b/forward/temp/calc_temp.f90
@@ -0,0 +1,90 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief top level routine for setup and compute temperature
+!> @param[in] ismpl local sample index
+ SUBROUTINE calc_temp(ismpl)
+ use arrays
+ use mod_genrlc
+ use mod_genrl
+ use mod_temp
+ use mod_time
+ use mod_linfos
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+ DOUBLE PRECISION vxc, vyc, vzc, por, kx, ky, kz, lx, ly, lz, &
+ rhoceff
+ EXTERNAL vxc, vyc, vzc, por, kx, ky, kz, lx, ly, lz, rhoceff
+ DOUBLE PRECISION vx, vy, vz, rhocf, rhocm
+ EXTERNAL vx, vy, vz, rhocf, rhocm
+ INTEGER ijk
+ integer :: i
+ integer :: ismpl
+
+ IF (linfos(3)>=2) WRITE(*,*) ' ... calc_temp'
+!
+! selecting a part for each thread
+#ifdef fOMP
+!$OMP parallel num_threads(Tlevel_1)
+!$ call omp_binding(ismpl)
+#endif
+
+ ijk = i0*j0*k0
+! default to mark a non-boundary
+!$OMP master
+ DO i = 1, ijk
+ bc_mask(i,ismpl) = '+'
+ END DO
+!$OMP end master
+! initialize coefficients for sparse solvers
+ CALL omp_set_dval(ijk,0.D0,a(1,1,1,ismpl))
+ CALL omp_set_dval(ijk,0.D0,b(1,1,1,ismpl))
+ CALL omp_set_dval(ijk,0.D0,c(1,1,1,ismpl))
+ CALL omp_set_dval(ijk,0.D0,d(1,1,1,ismpl))
+ CALL omp_set_dval(ijk,0.D0,e(1,1,1,ismpl))
+ CALL omp_set_dval(ijk,0.D0,f(1,1,1,ismpl))
+ CALL omp_set_dval(ijk,0.D0,g(1,1,1,ismpl))
+ CALL omp_set_dval(ijk,0.D0,w(1,1,1,ismpl))
+
+!$OMP barrier
+! calculate coefficients
+ CALL set_tcoef(ismpl)
+! set energy sources/sinks
+ CALL set_tq(ismpl)
+
+!$OMP barrier
+ CALL set_tcoefrs(ismpl)
+#ifdef fOMP
+!$OMP end parallel
+#endif
+
+! set boundary conditions
+ CALL set_tbc(ismpl)
+
+ IF (linfos(3)>=2) WRITE(*,*) ' ... solve(temp)'
+! solve it
+ CALL solve(pv_temp,-1,temp(1,1,1,ismpl),errt,apart,controlt, &
+ ismpl)
+
+ RETURN
+ END
diff --git a/forward/temp/neumann_temp.f90 b/forward/temp/neumann_temp.f90
new file mode 100644
index 0000000..cdea387
--- /dev/null
+++ b/forward/temp/neumann_temp.f90
@@ -0,0 +1,203 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief OpenMP wrapper for "omp_neumann_temp"
+!> @param[out] neumann_max neumann criteria
+!> @param[in] ismpl local sample index
+ SUBROUTINE neumann_temp(neumann_max,ismpl)
+ use mod_genrl
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ integer :: ismpl
+
+ INCLUDE 'OMP_TOOLS.inc'
+ DOUBLE PRECISION neumann_max
+
+#ifdef fOMP
+!$OMP parallel num_threads(Tlevel_1)
+!$ call omp_binding(ismpl)
+#endif
+ CALL omp_neumann_temp(neumann_max,ismpl)
+#ifdef fOMP
+!$OMP end parallel
+#endif
+
+ RETURN
+ END
+
+!> @brief calculate grid neuman numbers (temp)
+!> @param[out] neumann_max maximal neuman number
+!> @param[in] ismpl local sample index
+ SUBROUTINE omp_neumann_temp(neumann_max,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_temp
+ use mod_time
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+
+
+ INTEGER c1, c2, c3
+ DOUBLE PRECISION neumann_maxx, neumann_minx, neumann_avgx
+ DOUBLE PRECISION neumann_maxy, neumann_miny, neumann_avgy
+ DOUBLE PRECISION neumann_maxz, neumann_minz, neumann_avgz
+ DOUBLE PRECISION val, neumann_max, delt, fac, davg
+ DOUBLE PRECISION deltat
+ EXTERNAL deltat
+ DOUBLE PRECISION li, lj, lk, rhocf, por, rhoceff
+ EXTERNAL li, lj, lk, rhocf, por, rhoceff
+
+
+ delt = deltat(simtime(ismpl),ismpl)
+
+ IF ( .NOT. (transient .AND. tr_switch(ismpl))) THEN
+!$OMP master
+ WRITE(*,*) ' neumann-temp: not defined for steady state'
+!$OMP end master
+ RETURN
+ ELSE IF (linfos(3)>=2) THEN
+!$OMP master
+ WRITE(*,*)
+ WRITE(*,'(A,1e16.8)') ' ... neumann-temp: delt/tunit = ', &
+ delt/tunit
+ WRITE(*,*)
+!$OMP end master
+ END IF
+
+! val in x
+ c1 = 0
+ neumann_maxx = small
+ neumann_minx = big
+ neumann_avgx = 0.0D0
+!$OMP do schedule(static)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 2, i0 - 1
+ c1 = c1 + 1
+ davg = 0.5D0*(delx(i)+delx(i+1))
+ fac = delt/rhoceff(i,j,k,ismpl)
+ val = fac*li(i,j,k,ismpl)/(davg*davg)
+ IF (val>neumann_maxx) neumann_maxx = val
+ IF (val<neumann_minx) neumann_minx = val
+ neumann_avgx = neumann_avgx + val
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+
+! val in y
+ c2 = 0
+ neumann_maxy = small
+ neumann_miny = big
+ neumann_avgy = 0.0D0
+!$OMP do schedule(static)
+ DO k = 1, k0
+ DO j = 2, j0 - 1
+ DO i = 1, i0
+ c2 = c2 + 1
+ davg = 0.5D0*(dely(j)+dely(j+1))
+ fac = delt/rhoceff(i,j,k,ismpl)
+ val = fac*lj(i,j,k,ismpl)/(davg*davg)
+ IF (val>neumann_maxy) neumann_maxy = val
+ IF (val<neumann_miny) neumann_miny = val
+ neumann_avgy = neumann_avgy + val
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+
+! val in z
+ c3 = 0
+ neumann_maxz = small
+ neumann_minz = big
+ neumann_avgz = 0.0D0
+!$OMP do schedule(static)
+ DO k = 2, k0 - 1
+ DO j = 1, j0
+ DO i = 1, i0
+ c3 = c3 + 1
+ davg = 0.5D0*(delz(k)+delz(k+1))
+ fac = delt/rhoceff(i,j,k,ismpl)
+ val = fac*lk(i,j,k,ismpl)/(davg*davg)
+ IF (val>neumann_maxz) neumann_maxz = val
+ IF (val<neumann_minz) neumann_minz = val
+ neumann_avgz = neumann_avgz + val
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+
+! compute global sum for all values
+ CALL omp_summe(neumann_maxx,neumann_minx,neumann_avgx, &
+ neumann_maxy,neumann_miny,neumann_avgy,neumann_maxz, &
+ neumann_minz,neumann_avgz,c1,c2,c3,ismpl)
+
+!$OMP master
+ IF (i0>2) THEN
+ neumann_avgx = neumann_avgx/dble(c1)
+ ELSE
+ neumann_maxx = 0.0D0
+ neumann_minx = 0.0D0
+ neumann_avgx = 0.0D0
+ END IF
+ IF (j0>2) THEN
+ neumann_avgy = neumann_avgy/dble(c2)
+ ELSE
+ neumann_maxy = 0.0D0
+ neumann_miny = 0.0D0
+ neumann_avgy = 0.0D0
+ END IF
+ IF (k0>2) THEN
+ neumann_avgz = neumann_avgz/dble(c3)
+ ELSE
+ neumann_maxz = 0.0D0
+ neumann_minz = 0.0D0
+ neumann_avgz = 0.0D0
+ END IF
+
+ neumann_max = max(neumann_maxx,neumann_maxy,neumann_maxz)
+
+ IF (linfos(3)>=2) THEN
+ WRITE(*,*) 'neumann number for temperature in x,y,z:'
+ WRITE(*,'(a,1e10.3,a,1e10.3,a,1e10.3)') ' max. : ', &
+ neumann_maxx, ', ', neumann_maxy, ', ', neumann_maxz
+ WRITE(*,'(a,1e10.3,a,1e10.3,a,1e10.3)') ' min. : ', &
+ neumann_minx, ', ', neumann_miny, ', ', neumann_minz
+ WRITE(*,'(a,1e10.3,a,1e10.3,a,1e10.3)') ' avg. : ', &
+ neumann_avgx, ', ', neumann_avgy, ', ', neumann_avgz
+ END IF
+
+ IF (linfos(3)>=1 .AND. neumann_max>1.D0) THEN
+ WRITE(*,'(a)') &
+ '!!!: neumann temp number(s) greater than 1 :'
+ WRITE(*,'(a,1e12.3,a,1e10.3,a,1e10.3)') 'x: ', &
+ neumann_maxx, 'y: ', neumann_maxy, 'z: ', neumann_maxz
+ WRITE(*,*)
+ END IF
+!$OMP end master
+
+ RETURN
+ END
diff --git a/forward/temp/peclet_temp.f90 b/forward/temp/peclet_temp.f90
new file mode 100644
index 0000000..70fa6e4
--- /dev/null
+++ b/forward/temp/peclet_temp.f90
@@ -0,0 +1,217 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief OpenMP wrapper for "omp_peclet_temp"
+!> @param[out] peclet_max peclet criteria
+!> @param[in] ismpl local sample index
+ SUBROUTINE peclet_temp(peclet_max,ismpl)
+ use mod_genrl
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ integer :: ismpl
+ INCLUDE 'OMP_TOOLS.inc'
+ DOUBLE PRECISION peclet_max
+
+#ifdef fOMP
+!$OMP parallel num_threads(Tlevel_1)
+!$ call omp_binding(ismpl)
+#endif
+ CALL omp_peclet_temp(peclet_max,ismpl)
+#ifdef fOMP
+!$OMP end parallel
+#endif
+!
+ RETURN
+ END
+
+!> @brief calculate grid peclet numbers (temperature)
+!> @param[out] peclet_max peclet criteria
+!> @param[in] ismpl local sample index
+ SUBROUTINE omp_peclet_temp(peclet_max,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_temp
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+
+ INTEGER c1, c2, c3
+ DOUBLE PRECISION peclet_maxx, peclet_minx, peclet_avgx, &
+ peclet_maxy, peclet_miny, peclet_avgy, peclet_maxz, &
+ peclet_minz, peclet_avgz, val, davg, peclet_max
+ INTEGER ipt, jpt, kpt
+ DOUBLE PRECISION li, lj, lk, rhocf, vx, vy, vz, por
+ EXTERNAL li, lj, lk, rhocf, vx, vy, vz, por
+
+ IF (linfos(3)>=2) THEN
+!$OMP master
+ WRITE(*,*)
+ WRITE(*,'(A,1e16.8)') ' ... peclet-temp'
+ WRITE(*,*)
+!$OMP end master
+ END IF
+!
+! temperature-val in x
+ peclet_maxx = small
+ peclet_minx = big
+ peclet_avgx = 0.0D0
+ val = 0.0D0
+ ipt = 0
+ jpt = 0
+ kpt = 0
+ c1 = 0
+!$OMP do schedule(static)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 2, i0 - 1
+ c1 = c1 + 1
+ davg = 0.5D0*(delx(i)+delx(i+1))
+ val = abs(vx(i,j,k,ismpl))*davg/li(i,j,k,ismpl)
+ IF (val>peclet_maxx) THEN
+ peclet_maxx = val
+ ipt = i
+ jpt = j
+ kpt = k
+ END IF
+ IF (val<peclet_minx) peclet_minx = val
+ peclet_avgx = peclet_avgx + val
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+! if (linfos(3).ge.2)write(*,*)
+! & "max. temp-val in x: ", ipt,jpt,kpt
+!
+! temperature-val in y
+ peclet_maxy = small
+ peclet_miny = big
+ peclet_avgy = 0.0D0
+ val = 0.0D0
+ ipt = 0
+ jpt = 0
+ kpt = 0
+ c2 = 0
+!$OMP do schedule(static)
+ DO k = 1, k0
+ DO j = 2, j0 - 1
+ DO i = 1, i0
+ c2 = c2 + 1
+ davg = 0.5D0*(dely(j)+dely(j+1))
+ val = abs(vy(i,j,k,ismpl))*davg/lj(i,j,k,ismpl)
+ IF (val>peclet_maxy) THEN
+ peclet_maxy = val
+ ipt = i
+ jpt = j
+ kpt = k
+ END IF
+ IF (val<peclet_miny) peclet_miny = val
+ peclet_avgy = peclet_avgy + val
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+! if(linfos(3).ge.2)
+! & write(*,*)"max. temp-val in y: " ,ipt,jpt,kpt
+!
+! temperature-val in z
+ peclet_maxz = small
+ peclet_minz = big
+ peclet_avgz = 0.0D0
+ val = 0.0D0
+ ipt = 0
+ jpt = 0
+ kpt = 0
+ c3 = 0
+!$OMP do schedule(static)
+ DO k = 2, k0 - 1
+ DO j = 1, j0
+ DO i = 1, i0
+ c3 = c3 + 1
+ davg = 0.5D0*(delz(k)+delz(k+1))
+ val = abs(vz(i,j,k,ismpl))*davg/lk(i,j,k,ismpl)
+ IF (val>peclet_maxz) THEN
+ peclet_maxz = val
+ ipt = i
+ jpt = j
+ kpt = k
+ END IF
+ IF (val<peclet_minz) peclet_minz = val
+ peclet_avgz = peclet_avgz + val
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+! if(linfos(3).ge.2)
+! & write(*,*)"max. temp-val in z: " ,ipt,jpt,kpt
+!
+! compute global sum for all values
+ CALL omp_summe(peclet_maxx,peclet_minx,peclet_avgx, &
+ peclet_maxy,peclet_miny,peclet_avgy,peclet_maxz,peclet_minz, &
+ peclet_avgz,c1,c2,c3,ismpl)
+!
+!$OMP master
+ IF (i0>2) THEN
+ peclet_avgx = peclet_avgx/dble(c1)
+ ELSE
+ peclet_maxx = 0.0D0
+ peclet_minx = 0.0D0
+ peclet_avgx = 0.0D0
+ END IF
+ IF (j0>2) THEN
+ peclet_avgy = peclet_avgy/dble(c2)
+ ELSE
+ peclet_maxy = 0.0D0
+ peclet_miny = 0.0D0
+ peclet_avgy = 0.0D0
+ END IF
+ IF (k0>2) THEN
+ peclet_avgz = peclet_avgz/dble(c3)
+ ELSE
+ peclet_maxz = 0.0D0
+ peclet_minz = 0.0D0
+ peclet_avgz = 0.0D0
+ END IF
+!
+ peclet_max = max(peclet_avgx,peclet_avgy,peclet_avgz)
+!
+ IF (linfos(3)>=2) THEN
+ WRITE(*,*) 'peclet number for temperature in x,y,z:'
+ WRITE(*,'(a,1e12.3,a,1e10.3,a,1e10.3)') ' max. : ', &
+ peclet_maxx, ', ', peclet_maxy, ', ', peclet_maxz
+ WRITE(*,'(a,1e12.3,a,1e10.3,a,1e10.3)') ' min. : ', &
+ peclet_minx, ', ', peclet_miny, ', ', peclet_minz
+ WRITE(*,'(a,1e12.3,a,1e10.3,a,1e10.3)') ' avg. : ', &
+ peclet_avgx, ', ', peclet_avgy, ', ', peclet_avgz
+ END IF
+!
+ IF (peclet_max>2.0D0 .AND. linfos(3)>=1) THEN
+ WRITE(*,'(1A)') '!!!: peclet number for temperature > 2 :'
+ WRITE(*,'(a,1e12.3,a,1e10.3,a,1e10.3)') 'x: ', peclet_maxx, &
+ 'y: ', peclet_maxy, 'z: ', peclet_maxz
+ END IF
+!$OMP end master
+!
+ RETURN
+ END
diff --git a/forward/temp/set_tbc.f90 b/forward/temp/set_tbc.f90
new file mode 100644
index 0000000..1a25ab2
--- /dev/null
+++ b/forward/temp/set_tbc.f90
@@ -0,0 +1,286 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief coefficents for the heat equation
+!> @param[in] ismpl local sample index
+!> @details
+!> modify coefficents for the heat equation according to the prescribed sources and sinks.\n
+!> coefficients are stored as vectors in the diagonals a-g (d center) and rhs in w.\n
+ SUBROUTINE set_tbc(ismpl)
+ use arrays
+ use mod_genrl
+ use mod_temp
+ use mod_time
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+ integer :: ib
+ INTEGER bcu
+ ! INTEGER ac, bc
+ INTEGER tpbcu, bctype, i_dir
+ DOUBLE PRECISION val, malfa, mbeta, vx, vy, vz, dv, ds, vv
+ EXTERNAL vx, vy, vz
+ INTRINSIC max
+
+
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! flow due to flow neumann nodes / wellars - - - - - - - - - - - - - -
+
+ DO ib = first_flow, last_flow
+ i = ibc_data(ib,cbc_i)
+ j = ibc_data(ib,cbc_j)
+ k = ibc_data(ib,cbc_k)
+ bcu = ibc_data(ib,cbc_bcu)
+ tpbcu = max(ibc_data(ib,cbc_bctp),0)
+ bctype = ibc_data(ib,cbc_bt)
+! "neumann"?, skip otherwise
+ IF (bctype==bt_neum.OR.bctype==bt_neuw) THEN
+! discrete values
+ IF (bcu<=0) THEN
+ val = dbc_data(ib,1,ismpl)
+ ELSE
+ val = propunit(bcu,idx_hbc,ismpl)
+ END IF
+
+ IF ((tpbcu>0) .AND. nbctp>0) THEN
+! time-dependent bc: val=ac*val+bc
+! get Alfa and Beta modificators
+ CALL get_tpbcalbe(malfa,mbeta,tpbcu,ismpl)
+! update time dependend modification of the bc-value
+ val = malfa + mbeta*val
+ END IF
+
+! wellar test
+ IF (val<0.0D0 .AND. tpbcu>=0) THEN
+ ds = 0.D0
+ dv = 0.D0
+ IF (i>1) THEN
+ vv = abs(vx(i-1,j,k,ismpl))
+ ds = ds + vv
+ dv = dv + temp(i-1,j,k,ismpl)*vv
+! write(*,*) 'i- ',vv, temp(i-1,j,k,ismpl)
+ END IF
+ IF (i<i0) THEN
+ vv = abs(vx(i,j,k,ismpl))
+ ds = ds + vv
+ dv = dv + temp(i+1,j,k,ismpl)*vv
+! write(*,*) 'i+ ',vv, temp(i+1,j,k,ismpl)
+ END IF
+ IF (j>1) THEN
+ vv = abs(vy(i,j-1,k,ismpl))
+ ds = ds + vv
+ dv = dv + temp(i,j-1,k,ismpl)*vv
+! write(*,*) 'j- ',vv, temp(i,j-1,k,ismpl)
+ END IF
+ IF (j<j0) THEN
+ vv = abs(vy(i,j,k,ismpl))
+ ds = ds + vv
+ dv = dv + temp(i,j+1,k,ismpl)*vv
+! write(*,*) 'j+ ',vv, temp(i,j+1,k,ismpl)
+ END IF
+ IF (k>1) THEN
+ vv = abs(vz(i,j,k-1,ismpl))
+ ds = ds + vv
+ dv = dv + temp(i,j,k-1,ismpl)*vv
+! write(*,*) 'k- ',vv, temp(i,j,k-1,ismpl)
+ END IF
+ IF (k<k0) THEN
+ vv = abs(vz(i,j,k,ismpl))
+ ds = ds + vv
+ dv = dv + temp(i,j,k+1,ismpl)*vv
+! write(*,*) 'k+ ',vv, temp(i-1,j,k+1,ismpl)
+ END IF
+ dv = dv/ds
+! write(*,*) 'val: ',dv,ds
+! apply dirichlet update [dv]
+#ifdef BCMY
+! D = D+my
+ d(i,j,k,ismpl) = d(i,j,k,ismpl) - dbc_data(ib,2,ismpl)
+ w(i,j,k,ismpl) = w(i,j,k,ismpl) - &
+ dbc_data(ib,2,ismpl)*dv
+#else
+! standard boundary condition handling
+ a(i,j,k,ismpl) = 0.0D0
+ b(i,j,k,ismpl) = 0.0D0
+ c(i,j,k,ismpl) = 0.0D0
+ e(i,j,k,ismpl) = 0.0D0
+ f(i,j,k,ismpl) = 0.0D0
+ g(i,j,k,ismpl) = 0.0D0
+ d(i,j,k,ismpl) = 1.0D0
+ w(i,j,k,ismpl) = dv
+ temp(i,j,k,ismpl) = dv
+! mark as boundary for normalising the lin. system
+ bc_mask(i+(j-1)*i0+(k-1)*i0*j0,ismpl) = '0'
+#endif
+ END IF
+ END IF
+ END DO
+
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! dirichlet nodes - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ DO ib = first_temp, last_temp
+ i = ibc_data(ib,cbc_i)
+ j = ibc_data(ib,cbc_j)
+ k = ibc_data(ib,cbc_k)
+ bcu = ibc_data(ib,cbc_bcu)
+ tpbcu = max(ibc_data(ib,cbc_bctp),0)
+ bctype = ibc_data(ib,cbc_bt)
+! "dirichlet"?, skip otherwise
+ IF (bctype==bt_diri) THEN
+! discrete values
+ IF (bcu<=0) THEN
+ val = dbc_data(ib,1,ismpl)
+ ELSE
+ val = propunit(bcu,idx_tbc,ismpl)
+ END IF
+
+ IF ((tpbcu>0) .AND. nbctp>0) THEN
+! time-dependent bc: val=ac*val+bc
+! get Alfa and Beta modificators
+ CALL get_tpbcalbe(malfa,mbeta,tpbcu,ismpl)
+! update time dependend modification of the bc-value
+ val = malfa + mbeta*val
+ END IF
+
+ IF (tpbcu>=0) THEN
+#ifdef BCMY
+! D = D+my
+ d(i,j,k,ismpl) = d(i,j,k,ismpl) - dbc_data(ib,2,ismpl)
+ w(i,j,k,ismpl) = w(i,j,k,ismpl) - &
+ dbc_data(ib,2,ismpl)*val
+#else
+! standard boundary condition handling
+ a(i,j,k,ismpl) = 0.0D0
+ b(i,j,k,ismpl) = 0.0D0
+ c(i,j,k,ismpl) = 0.0D0
+ e(i,j,k,ismpl) = 0.0D0
+ f(i,j,k,ismpl) = 0.0D0
+ g(i,j,k,ismpl) = 0.0D0
+ d(i,j,k,ismpl) = 1.0D0
+ w(i,j,k,ismpl) = val
+ temp(i,j,k,ismpl) = val
+! mark as boundary for normalising the lin. system
+ bc_mask(i+(j-1)*i0+(k-1)*i0*j0,ismpl) = '0'
+#endif
+ END IF
+ END IF
+ END DO
+
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! neumann nodes - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ DO ib = first_temp, last_temp
+ i = ibc_data(ib,cbc_i)
+ j = ibc_data(ib,cbc_j)
+ k = ibc_data(ib,cbc_k)
+ bcu = ibc_data(ib,cbc_bcu)
+ tpbcu = max(ibc_data(ib,cbc_bctp),0)
+ bctype = ibc_data(ib,cbc_bt)
+ i_dir = ibc_data(ib,cbc_dir)
+! "neumann"?, skip otherwise
+ IF (bctype==bt_neum) THEN
+! discrete values
+ IF (bcu<=0) THEN
+ val = dbc_data(ib,1,ismpl)
+ ELSE
+ val = propunit(bcu,idx_tbc,ismpl)
+ END IF
+
+ IF ((tpbcu>0) .AND. nbctp>0) THEN
+! time-dependent bc: val=ac*val+bc
+! get Alfa and Beta modificators
+ CALL get_tpbcalbe(malfa,mbeta,tpbcu,ismpl)
+! update time dependend modification of the bc-value
+ val = malfa + mbeta*val
+ END IF
+
+ IF (tpbcu>=0) THEN
+ IF ((i_dir==0)) val = val/(delx(i)*dely(j)*delz(k))
+ IF ((i_dir==1) .OR. (i_dir==2)) val = val/delx(i)
+ IF ((i_dir==3) .OR. (i_dir==4)) val = val/dely(j)
+ IF ((i_dir==5) .OR. (i_dir==6)) val = val/delz(k)
+
+ w(i,j,k,ismpl) = w(i,j,k,ismpl) - val
+ END IF
+ END IF
+ END DO
+
+ RETURN
+ END
+
+!> @brief modify TEMP for the heat equation according
+!> @param[in] ismpl local sample index
+!> @details
+!> modify TEMP for the heat equation according to the boundary conditions.\n
+ SUBROUTINE set_dtbc(ismpl)
+ use arrays
+ use mod_genrl
+ use mod_temp
+ use mod_time
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+ integer :: ib
+ INTEGER bcu, tpbcu, bctype
+ DOUBLE PRECISION val, malfa, mbeta
+ INTRINSIC max
+
+
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+! dirichlet nodes - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+!$OMP do schedule(static)
+ DO ib = first_temp, last_temp
+ i = ibc_data(ib,cbc_i)
+ j = ibc_data(ib,cbc_j)
+ k = ibc_data(ib,cbc_k)
+ bcu = ibc_data(ib,cbc_bcu)
+ tpbcu = max(ibc_data(ib,cbc_bctp),0)
+ bctype = ibc_data(ib,cbc_bt)
+! "dirichlet"?, skip otherwise
+ IF (bctype==bt_diri) THEN
+! discrete values
+ IF (bcu<=0) THEN
+ val = dbc_data(ib,1,ismpl)
+ ELSE
+ val = propunit(bcu,idx_tbc,ismpl)
+ END IF
+
+ IF ((tpbcu>0) .AND. nbctp>0) THEN
+! time-dependent bc: val=ac*val+bc
+! get Alfa and Beta modificators
+ CALL get_tpbcalbe(malfa,mbeta,tpbcu,ismpl)
+! update time dependend modification of the bc-value
+ val = malfa + mbeta*val
+ END IF
+
+ IF (tpbcu>=0) temp(i,j,k,ismpl) = val
+ END IF
+ END DO
+!$OMP end do nowait
+
+ RETURN
+ END
diff --git a/forward/temp/set_tcoef.f90 b/forward/temp/set_tcoef.f90
new file mode 100644
index 0000000..bac48fb
--- /dev/null
+++ b/forward/temp/set_tcoef.f90
@@ -0,0 +1,274 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculate coefficents for the heat equation
+!> @param[in] ismpl local sample index
+!> @details
+!> calculate coefficents for the heat equation\n
+!> coefficients are stored as vectors in the diagonals a-g (d center) and rhs in w.\n
+ SUBROUTINE set_tcoef(ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_temp
+ use mod_time
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+
+
+ DOUBLE PRECISION li, lj, lk, rhocf, vx, vy, vz, alfa, amean
+ EXTERNAL li, lj, lk, rhocf, vx, vy, vz, alfa, amean
+
+ DOUBLE PRECISION rijk, ra, rc, va, la, alf, p2
+
+
+!$OMP master
+ IF (linfos(3)>=2) WRITE(*,*) ' ... tcoef'
+!$OMP end master
+
+! initialize coefficients for sparse solvers
+
+! inner points of grid - - - - - - - - - - - - - - - - - - - - - - - - -
+
+!$OMP do schedule(static) collapse(3)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+
+ rijk = rhocf(i,j,k,ismpl)
+
+ IF (i0>1) THEN
+ IF (i<i0) THEN
+ la = li(i,j,k,ismpl)
+ ra = amean(rhocf(i+1,j,k,ismpl),rijk)
+ va = vx(i,j,k,ismpl)
+ rc = 0.5*ra*va
+ IF (la>0.D0) THEN
+ p2 = rc/la
+ alf = alfa(p2)
+ ELSE
+ alf = 0.D0
+ IF (va<0.D0) alf = -1.D0
+ IF (va>0.D0) alf = 1.D0
+ END IF
+ e(i,j,k,ismpl) = (la-(1.D0-alf)*rc)/delx(i)
+ d(i,j,k,ismpl) = d(i,j,k,ismpl) - &
+ (la+(1.D0+alf)*rc)/delx(i)
+ END IF
+
+ IF (i>1) THEN
+ la = li(i-1,j,k,ismpl)
+ ra = amean(rhocf(i-1,j,k,ismpl),rijk)
+ va = vx(i-1,j,k,ismpl)
+ rc = 0.5*ra*va
+ alf = 0.D0
+ IF (va==0.D0) THEN
+ alf = 0.D0
+ ELSE
+ IF (la>0.D0) THEN
+ p2 = rc/la
+ alf = alfa(p2)
+ ELSE
+ IF (va<0.D0) alf = -1.D0
+ IF (va>0.D0) alf = 1.D0
+ END IF
+ END IF
+ c(i,j,k,ismpl) = (la+(1.D0+alf)*rc)/delx(i)
+ d(i,j,k,ismpl) = d(i,j,k,ismpl) - &
+ (la-(1.D0-alf)*rc)/delx(i)
+ END IF
+ END IF
+
+ IF (j0>1) THEN
+
+ IF (j<j0) THEN
+ la = lj(i,j,k,ismpl)
+ ra = amean(rhocf(i,j+1,k,ismpl),rijk)
+ va = vy(i,j,k,ismpl)
+ rc = 0.5D0*ra*va
+ alf = 0.D0
+ IF (va==0.D0) THEN
+ alf = 0.D0
+ ELSE
+ IF (la>0.D0) THEN
+ p2 = rc/la
+ alf = alfa(p2)
+ ELSE
+ IF (va<0.D0) alf = -1.D0
+ IF (va>0.D0) alf = 1.D0
+ END IF
+ END IF
+ f(i,j,k,ismpl) = (la-(1.D0-alf)*rc)/dely(j)
+ d(i,j,k,ismpl) = d(i,j,k,ismpl) - &
+ (la+(1.D0+alf)*rc)/dely(j)
+ END IF
+
+ IF (j>1) THEN
+ la = lj(i,j-1,k,ismpl)
+ ra = amean(rhocf(i,j-1,k,ismpl),rijk)
+ va = vy(i,j-1,k,ismpl)
+ rc = 0.5*ra*va
+ alf = 0.D0
+ IF (va==0.D0) THEN
+ alf = 0.D0
+ ELSE
+ IF (la>0.D0) THEN
+ p2 = rc/la
+ alf = alfa(p2)
+ ELSE
+ IF (va<0.D0) alf = -1.D0
+ IF (va>0.D0) alf = 1.D0
+ END IF
+ END IF
+ b(i,j,k,ismpl) = (la+(1.D0+alf)*rc)/dely(j)
+ d(i,j,k,ismpl) = d(i,j,k,ismpl) - &
+ (la-(1.D0-alf)*rc)/dely(j)
+ END IF
+ END IF
+
+ IF (k0>1) THEN
+
+ IF (k<k0) THEN
+ la = lk(i,j,k,ismpl)
+ ra = amean(rhocf(i,j,k+1,ismpl),rijk)
+ va = vz(i,j,k,ismpl)
+ rc = 0.5*ra*va
+ alf = 0.D0
+ IF (va==0.D0) THEN
+ alf = 0.D0
+ ELSE
+ IF (la>0.D0) THEN
+ p2 = rc/la
+ alf = alfa(p2)
+ ELSE
+ IF (va<0.D0) alf = -1.D0
+ IF (va>0.D0) alf = 1.D0
+ END IF
+ END IF
+ g(i,j,k,ismpl) = (la-(1.D0-alf)*rc)/delz(k)
+ d(i,j,k,ismpl) = d(i,j,k,ismpl) - &
+ (la+(1.D0+alf)*rc)/delz(k)
+ END IF
+
+ IF (k>1) THEN
+ la = lk(i,j,k-1,ismpl)
+ ra = amean(rhocf(i,j,k-1,ismpl),rijk)
+ va = vz(i,j,k-1,ismpl)
+ rc = 0.5*ra*va
+ alf = 0.D0
+ IF (va==0.D0) THEN
+ alf = 0.D0
+ ELSE
+ IF (la>0.D0) THEN
+ p2 = rc/la
+ alf = alfa(p2)
+ ELSE
+ IF (va<0.D0) alf = -1.D0
+ IF (va>0.D0) alf = 1.D0
+ END IF
+ END IF
+ a(i,j,k,ismpl) = (la+(1.D0+alf)*rc)/delz(k)
+ d(i,j,k,ismpl) = d(i,j,k,ismpl) - &
+ (la-(1.D0-alf)*rc)/delz(k)
+ END IF
+ END IF
+
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+
+ RETURN
+ END
+
+!> @brief coefficents for the heat equation (here right hand side)
+!> @param[in] ismpl local sample index
+!> @details
+!> calculate coefficents for the heat equation\n
+!> coefficients are stored as vectors in the diagonals a-g (d center) and rhs in w.\n
+ SUBROUTINE set_tcoefrs(ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_temp
+ use mod_time
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+
+
+ DOUBLE PRECISION deltt, rce
+ ! INTEGER c1, c2, c3, c4
+
+ DOUBLE PRECISION rhoceff, por, qt, deltat
+ EXTERNAL rhoceff, por, qt, deltat
+
+
+ deltt = deltat(simtime(ismpl),ismpl)
+
+! - - rhs: sources, also terms for transient caolculations - - - - - - - - -
+
+ IF (transient .AND. tr_switch(ismpl)) THEN
+! - - - - - - - transient - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+ CALL omp_mvp(i0,j0,k0,tempold(1,cgen_time,ismpl), &
+ x(1,1,1,ismpl),a(1,1,1,ismpl),b(1,1,1,ismpl), &
+ c(1,1,1,ismpl),d(1,1,1,ismpl),e(1,1,1,ismpl), &
+ f(1,1,1,ismpl),g(1,1,1,ismpl))
+
+!$OMP do schedule(static) collapse(3)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+! add solid and fluid heat production, boundary terms
+ rce = rhoceff(i,j,k,ismpl)
+ d(i,j,k,ismpl) = d(i,j,k,ismpl) - rce/(deltt*thetat)
+ w(i,j,k,ismpl) = w(i,j,k,ismpl) - &
+ rce*tempold(i+(j-1)*i0+(k-1)*i0*j0,cgen_time,ismpl)/ &
+ deltt - (1.D0-thetat)*x(i,j,k,ismpl) - &
+ hpf*por(i,j,k,ismpl)
+ w(i,j,k,ismpl) = w(i,j,k,ismpl)/thetat
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+ ELSE
+! - - - - - - - - steady state - - - - - - - - - - - - - - - - - - - - -
+!$OMP do schedule(static) collapse(3)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+! solid and fluid heat production
+ w(i,j,k,ismpl) = w(i,j,k,ismpl) - hpf*por(i,j,k,ismpl)
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+ END IF
+
+ RETURN
+ END
diff --git a/forward/temp/set_tq.f90 b/forward/temp/set_tq.f90
new file mode 100644
index 0000000..2974334
--- /dev/null
+++ b/forward/temp/set_tq.f90
@@ -0,0 +1,76 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief modify coefficents for the temperature equation
+!> @param[in] ismpl local sample index
+!> @details
+!> modify coefficents for the temperature equation according to the prescribed sources and sinks\n
+!> rhs stored in w.\n
+ SUBROUTINE set_tq(ismpl)
+ use arrays
+ use mod_genrl
+ use mod_time
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION deltat, deltt, qt
+ EXTERNAL deltat, qt
+! rhs: sources
+ IF (transient .AND. tr_switch(ismpl)) THEN
+ deltt = deltat(simtime(ismpl),ismpl)
+!$OMP do schedule(static) collapse(3)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ w(i,j,k,ismpl) = w(i,j,k,ismpl) - qt(i,j,k,ismpl)
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+ ELSE
+!$OMP do schedule(static) collapse(3)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ w(i,j,k,ismpl) = w(i,j,k,ismpl) - qt(i,j,k,ismpl)
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+ END IF
+
+! Heat sources associated with flow dirichlet nodes - - - - - - -
+
+! do ib=first_flow,last_flow
+! i=ibc_data(ib,cbc_i)
+! j=ibc_data(ib,cbc_j)
+! k=ibc_data(ib,cbc_k)
+! bctype=ibc_data(ib,cbc_bt)
+! if (bctype.eq.bt_diri) then
+! w(i,j,k)=w(i,j,k)-qheadbcd(i,j,k,ismpl) ??? Zeit-Abhaengikeit ???
+! write(99,'(3i6,4x,e15.5)') i,j,k,qheadbcd(i,j,k,ismpl)
+! endif
+! end do
+
+ RETURN
+ END
diff --git a/forward/temp/tfluxes.f90 b/forward/temp/tfluxes.f90
new file mode 100644
index 0000000..0d21998
--- /dev/null
+++ b/forward/temp/tfluxes.f90
@@ -0,0 +1,356 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculate x heat flux at cell faces
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return x heat flux (W/m^2)
+ DOUBLE PRECISION FUNCTION qx(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+ DOUBLE PRECISION dif, li
+ EXTERNAL li
+
+ qx = 0.D0
+ IF (i0>1 .AND. i<i0) THEN
+ dif = temp(i+1,j,k,ismpl) - temp(i,j,k,ismpl)
+ qx = -li(i,j,k,ismpl)*dif
+ END IF
+ RETURN
+ END
+
+!> @brief calculate y heat flux at cell faces
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return y heat flux (W/m^2)
+ DOUBLE PRECISION FUNCTION qy(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_temp
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION dif, lj
+ EXTERNAL lj
+
+ qy = 0.D0
+ IF (j0>1 .AND. j<j0) THEN
+ dif = temp(i,j+1,k,ismpl) - temp(i,j,k,ismpl)
+ qy = -lj(i,j,k,ismpl)*dif
+ END IF
+
+ RETURN
+ END
+
+!> @brief calculate z heat flux at cell faces
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return z heat flux (W/m^2)
+ DOUBLE PRECISION FUNCTION qz(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_temp
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION dif, lk
+ EXTERNAL lk
+
+ qz = 0.D0
+ IF (k0>1 .AND. k<k0) THEN
+ dif = temp(i,j,k+1,ismpl) - temp(i,j,k,ismpl)
+ qz = -lk(i,j,k,ismpl)*dif
+ END IF
+ RETURN
+ END
+
+!> @brief calculate x heat flux at cell centers
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return x heat flux (W/m^2)
+ DOUBLE PRECISION FUNCTION qxc(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ IMPLICIT NONE
+ DOUBLE PRECISION d1, d2, li, amean
+ integer :: ismpl
+ integer :: i, j, k
+ EXTERNAL li, amean
+
+ qxc = 0.D0
+ IF (i0<=1) RETURN
+ IF (i>1 .AND. i<i0) THEN
+ d1 = temp(i+1,j,k,ismpl) - temp(i,j,k,ismpl)
+ d2 = temp(i,j,k,ismpl) - temp(i-1,j,k,ismpl)
+ qxc = amean(-li(i,j,k,ismpl)*d1,-li(i-1,j,k,ismpl)*d2)
+ ELSE IF (i==1) THEN
+ qxc = -li(i,j,k,ismpl)*(temp(i+1,j,k,ismpl)-temp(i,j,k,ismpl &
+ ))
+ ELSE IF (i==i0) THEN
+ qxc = -li(i-1,j,k,ismpl)*(temp(i,j,k,ismpl)-temp(i-1,j,k, &
+ ismpl))
+ END IF
+ RETURN
+ END
+
+!> @brief calculate y heat fluxat cell center
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return y heat flux (W/m^2)
+ DOUBLE PRECISION FUNCTION qyc(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_temp
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION d1, d2, lj, amean
+ EXTERNAL lj, amean
+
+ qyc = 0.D0
+ IF (j0<=1) RETURN
+ IF (j>1 .AND. j<j0) THEN
+ d1 = temp(i,j+1,k,ismpl) - temp(i,j,k,ismpl)
+ d2 = temp(i,j,k,ismpl) - temp(i,j-1,k,ismpl)
+ qyc = amean(-lj(i,j,k,ismpl)*d1,-lj(i,j-1,k,ismpl)*d2)
+ ELSE IF (j==1) THEN
+ qyc = -lj(i,j,k,ismpl)*(temp(i,j+1,k,ismpl)-temp(i,j,k,ismpl &
+ ))
+ ELSE IF (j==j0) THEN
+ qyc = -lj(i,j-1,k,ismpl)*(temp(i,j,k,ismpl)-temp(i,j-1,k, &
+ ismpl))
+ END IF
+ RETURN
+ END
+
+!> @brief calculate z heat flux at cell center
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return z heat flux (W/m^2)
+ DOUBLE PRECISION FUNCTION qzc(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_temp
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION d1, d2, lk, amean
+ EXTERNAL lk, amean
+
+ qzc = 0.D0
+ IF (k0<=1) RETURN
+ IF (k>1 .AND. k<k0) THEN
+ d1 = temp(i,j,k+1,ismpl) - temp(i,j,k,ismpl)
+ d2 = temp(i,j,k,ismpl) - temp(i,j,k-1,ismpl)
+ qzc = amean(-lk(i,j,k,ismpl)*d1,-lk(i,j,k-1,ismpl)*d2)
+ ELSE IF (k==1) THEN
+ qzc = -lk(i,j,k,ismpl)*(temp(i,j,k+1,ismpl)-temp(i,j,k,ismpl &
+ ))
+ ELSE IF (k==k0) THEN
+ qzc = -lk(i,j,k-1,ismpl)*(temp(i,j,k,ismpl)-temp(i,j,k-1, &
+ ismpl))
+ END IF
+ RETURN
+ END
+
+!> @brief average thermal conductivities on cell faces in x direction
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return x thermal conductivity (J/mK)
+ DOUBLE PRECISION FUNCTION li(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_temp
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION f1, f2, prod, summ, lx
+ EXTERNAL lx
+
+ li = 0.D0
+ IF (i0>1 .AND. i<i0) THEN
+ f1 = lx(i,j,k,ismpl)
+ f2 = lx(i+1,j,k,ismpl)
+ prod = f1*f2
+ summ = f1*delx(i+1) + f2*delx(i)
+ IF (summ>0.D0) li = 2.D0*prod/summ
+ END IF
+! write(99,'(a,5G14.5)') 'in li ',f1,f2,prod,summ,li
+ RETURN
+ END
+
+!> @brief average thermal conductivities on cell faces in y direction
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return y thermal conductivity (J/mK)
+ DOUBLE PRECISION FUNCTION lj(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_temp
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION f1, f2, prod, summ, ly
+ EXTERNAL ly
+
+ lj = 0.D0
+ IF (j0>1 .AND. j<j0) THEN
+ f1 = ly(i,j,k,ismpl)
+ f2 = ly(i,j+1,k,ismpl)
+ prod = f1*f2
+ summ = f1*dely(j+1) + f2*dely(j)
+ IF (summ>0.D0) lj = 2.D0*prod/summ
+ END IF
+ RETURN
+ END
+
+!> @brief average thermal conductivities on cell faces in z direction
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return z thermal conductivity (J/mK,ismpl)
+ DOUBLE PRECISION FUNCTION lk(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_temp
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION f1, f2, prod, summ, lz
+ EXTERNAL lz
+
+ lk = 0.D0
+ IF (k0>1 .AND. k<k0) THEN
+ f1 = lz(i,j,k,ismpl)
+ f2 = lz(i,j,k+1,ismpl)
+ prod = f1*f2
+ summ = f1*delz(k+1) + f2*delz(k)
+ IF (summ>0.D0) lk = 2.D0*prod/summ
+ END IF
+ RETURN
+ END
+
+!> @brief calculate advective heat flux at cell faces
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return x advective heat flux (W/m^2)
+ DOUBLE PRECISION FUNCTION qvx(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+ DOUBLE PRECISION tcf, vx, rhof, cpf
+ EXTERNAL vx, rhof, cpf
+
+ qvx = 0.D0
+ IF (i0>1 .AND. i<i0) THEN
+ tcf = (delx(i+1)*temp(i+1,j,k,ismpl)*rhof(i+1,j,k,ismpl)* &
+ cpf(i+1,j,k,ismpl)+delx(i)*temp(i,j,k,ismpl)*rhof(i,j,k, &
+ ismpl)*cpf(i,j,k,ismpl))/(delx(i+1)+delx(i))
+ qvx = delz(k)*dely(j)*tcf*vx(i,j,k,ismpl)
+ END IF
+ RETURN
+ END
+
+!> @brief calculate advective heat flux at cell faces
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return y advective heat flux (W/m^2)
+ DOUBLE PRECISION FUNCTION qvy(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_temp
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION tcf, vy, rhof, cpf
+ EXTERNAL vy, rhof, cpf
+
+ qvy = 0.D0
+ IF (j0>1 .AND. j<j0) THEN
+ tcf = (dely(j+1)*temp(i,j+1,k,ismpl)*rhof(i,j+1,k,ismpl)* &
+ cpf(i,j+1,k,ismpl)+dely(j)*temp(i,j,k,ismpl)*rhof(i,j,k, &
+ ismpl)*cpf(i,j,k,ismpl))/(dely(j+1)+dely(j))
+ qvy = delx(i)*delz(k)*tcf*vy(i,j,k,ismpl)
+ END IF
+ RETURN
+ END
+
+!> @brief calculate advective heat flux at cell faces
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return z advective heat flux (W/m^2)
+ DOUBLE PRECISION FUNCTION qvz(i,j,k,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_temp
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ DOUBLE PRECISION tcf, vz, rhof, cpf
+ EXTERNAL vz, rhof, cpf
+
+ qvz = 0.D0
+ IF (k0>1 .AND. k<k0) THEN
+ tcf = (delz(k+1)*temp(i,j,k+1,ismpl)*rhof(i,j,k+1,ismpl)* &
+ cpf(i,j,k+1,ismpl)+delz(k)*temp(i,j,k,ismpl)*rhof(i,j,k, &
+ ismpl)*cpf(i,j,k,ismpl))/(delz(k+1)+delz(k))
+ qvz = delx(i)*dely(j)*tcf*vz(i,j,k,ismpl)
+ END IF
+ RETURN
+ END
diff --git a/forward/test_opt.f90 b/forward/test_opt.f90
new file mode 100644
index 0000000..b2c068c
--- /dev/null
+++ b/forward/test_opt.f90
@@ -0,0 +1,100 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief test for a specific runtime option
+!> @param[in] soption expected runtime option (string)
+!> @return existence of the expected runtime option
+ LOGICAL FUNCTION test_option(soption)
+ IMPLICIT NONE
+ INTEGER i
+ character (len=80) :: param
+ character (len=*) :: soption
+ INTEGER p
+
+ test_option = .FALSE.
+ i = command_argument_count()
+ DO p = 1, i
+ CALL get_command_argument(p,param)
+ IF (param==soption) THEN
+ test_option = .TRUE.
+ RETURN
+ END IF
+ END DO
+ RETURN
+ END
+
+!> @brief integer value for a specific runtime option
+!> @param[in] soption runtime option (string)
+!> @return integer value for the defined runtime option
+ INTEGER FUNCTION get_ioptval(soption)
+ IMPLICIT NONE
+ INTEGER i
+ character (len=80) :: param
+ character (len=*) :: soption
+ INTEGER p, t
+
+ i = command_argument_count()
+ DO p = 1, i
+ CALL get_command_argument(p,param)
+ IF (param==soption) THEN
+ IF (i>p) THEN
+ t = p + 1
+ CALL get_command_argument(t,param)
+ READ(param,*) get_ioptval
+ RETURN
+ ELSE
+ WRITE(*,'(3A)') 'error: no option value for "', &
+ soption, '"!'
+ STOP
+ END IF
+ END IF
+ END DO
+ RETURN
+ END
+
+!> @brief returns the string value for a specific runtime option
+!> @param[in] soption runtime option (string)
+!> @param[out] param string value
+ SUBROUTINE get_coptval(soption,param)
+ IMPLICIT NONE
+ INTEGER i
+ character (len=*) :: param
+ character (len=*) :: soption
+ INTEGER p, t
+
+ i = command_argument_count()
+ DO p = 1, i
+ CALL get_command_argument(p,param)
+ IF (param==soption) THEN
+ IF (i>p) THEN
+ t = p + 1
+ CALL get_command_argument(t,param)
+ RETURN
+ ELSE
+ WRITE(*,'(3A)') 'error: no option value for "', &
+ soption, '"!'
+ STOP
+ END IF
+ END IF
+ END DO
+ RETURN
+ END
diff --git a/hdf5/close_hdf5.f90 b/hdf5/close_hdf5.f90
new file mode 100644
index 0000000..28b72f0
--- /dev/null
+++ b/hdf5/close_hdf5.f90
@@ -0,0 +1,56 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief close hdf5-file
+!> @details
+!> Closing hdf5 files, used in read-routines.
+!> Note: To be able to use input file parsing with hdf5, the
+!> hdf5-input-files have to be generated using the script:
+!> `convert_to_hdf5.py`. This script can be found in the repository
+!> `SHEMAT-Suite_Scripts` under
+!> `python/preprocessing/convert_to_hdf5.py`.
+ SUBROUTINE close_hdf5()
+#ifndef noHDF
+ USE hdf5
+ use mod_input_file_parser_hdf5
+ use mod_hdf5_vars, only: default_hdf_file, file_id, error
+#endif
+ IMPLICIT NONE
+
+
+#ifndef noHDF
+
+! Close hdf5 file.
+ IF (default_hdf_file/=' ') THEN
+ CALL h5fclose_f(file_id,error)
+ END IF
+ default_hdf_file = ' '
+
+! Close FORTRAN interface.
+ if (.not. h5parse_hdf5_environment) then
+ CALL h5close_f(error)
+ end if
+
+#endif
+ RETURN
+ END
+
diff --git a/hdf5/closeopen_hdf5.f90 b/hdf5/closeopen_hdf5.f90
new file mode 100644
index 0000000..a3d82d2
--- /dev/null
+++ b/hdf5/closeopen_hdf5.f90
@@ -0,0 +1,53 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief close and open hdf5-file, when the new one not the default
+!> @param[in] f_name hdf5 file name
+ SUBROUTINE closeopen_hdf5(f_name)
+#ifndef noHDF
+ USE hdf5
+ use mod_hdf5_vars, only: default_hdf_file, file_id, error
+#endif
+ IMPLICIT NONE
+
+! arrayname and filename
+ character (len=*) :: f_name
+
+#ifndef noHDF
+
+! Close and Reopen hdf5 file.
+ IF (f_name/=default_hdf_file) THEN
+! Close hdf5 file.
+ IF (default_hdf_file/=' ') THEN
+ CALL h5fclose_f(file_id,error)
+ END IF
+! Reopen hdf5 file.
+ default_hdf_file = f_name
+ IF (f_name/=' ') THEN
+ CALL h5fopen_f(f_name,h5f_acc_rdwr_f,file_id,error)
+ END IF
+ END IF
+
+#endif
+ RETURN
+ END
+
diff --git a/hdf5/mod_hdf5_vars.f90 b/hdf5/mod_hdf5_vars.f90
new file mode 100644
index 0000000..b758256
--- /dev/null
+++ b/hdf5/mod_hdf5_vars.f90
@@ -0,0 +1,59 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief shared hdf5 variables
+module mod_hdf5_vars
+
+#ifndef noHDF
+
+ use hdf5, only: hid_t
+
+ !> @brief Name of opened hdf file
+ !> @details
+ !> Name of opened hdf file. \n
+ !> Saves the name of the hdf file opened in open_hdf.
+ character (len=256) :: default_hdf_file
+
+ !> @brief HDF5 file id
+ !> @details
+ !> HDF5 file id. \n
+ !> HDF5 file id.
+ integer (kind=hid_t) :: file_id
+
+
+ !> @brief HDF5 Error flag
+ !> @details
+ !> HDF5 Error flag. \n
+ !> HDF5 Error flag to check operation success.
+#ifdef HDF6432
+ integer (kind=4) :: error
+#else
+#ifdef HDF64
+ integer (kind=8) :: error
+#else
+ integer :: error
+#endif
+#endif
+
+#endif
+
+end module mod_hdf5_vars
diff --git a/hdf5/mod_input_file_parser_hdf5.f90 b/hdf5/mod_input_file_parser_hdf5.f90
new file mode 100644
index 0000000..18f18da
--- /dev/null
+++ b/hdf5/mod_input_file_parser_hdf5.f90
@@ -0,0 +1,388 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief hdf5 input file parsing
+!> @details
+!> Note: To be able to use input file parsing with hdf5, the
+!> hdf5-input-files have to be generated using the script:
+!> `convert_to_hdf5.py`. This script can be found in the repository
+!> `SHEMAT-Suite_Scripts` under
+!> `python/preprocessing/convert_to_hdf5.py`.
+module mod_input_file_parser_hdf5
+ ! HDF5 input data format parser
+ ! Developed as part of the EoCoE project 2016
+ ! author: Sebastian Luehrs, JSC, Forschungszentrum Juelich
+#ifndef noHDF
+ use hdf5
+#ifdef fMPI
+ use mpi
+#endif
+ implicit none
+ ! globally available information, if HDF5 input file is used
+ logical :: h5parse_use_hdf5_datafile = .false.
+ logical :: h5parse_hdf5_environment = .false.
+ integer(kind=HID_T) :: file_id
+ private
+ public :: h5parse_read_dimension_size_for_dataset, h5parse_read_2d_double_dataset, &
+ & h5parse_read_1d_double_dataset, h5parse_use_hdf5_datafile, &
+ & h5parse_open_datafile, h5parse_close_datafile, h5parse_check_attr_exist, &
+ & h5parse_read_double_attribute, h5parse_read_integer_attribute, &
+ & h5parse_check_dataset_exist, h5parse_read_2d_integer_dataset, &
+ & h5parse_read_3d_double_dataset, h5parse_read_3d_integer_dataset, &
+ & h5parse_hdf5_environment
+contains
+
+ subroutine h5parse_init()
+ ! Initalize HDF5 Fortran interface
+ integer(kind=4) :: hdferr
+ call H5open_f(hdferr)
+ h5parse_hdf5_environment = .true.
+ end subroutine h5parse_init
+
+ subroutine h5parse_open_file(filename)
+ ! Open HDF5-datafile and store the filehandle
+ ! @param[in] filename: Input filename
+ character(len=80), intent(in) :: filename
+ integer(kind=HID_T) :: plist_id
+ integer(kind=4) :: hdferr
+#ifdef fMPI
+ ! set up file access propterty for parallel HDF5
+ call H5Pcreate_f(H5P_FILE_ACCESS_F, plist_id, hdferr)
+ call H5Pset_fapl_mpio_f(plist_id,MPI_COMM_WORLD,MPI_INFO_NULL,hdferr)
+#else
+ plist_id = H5P_DEFAULT_F
+#endif
+ ! create new file collectively and release property list identifier
+ call H5Fopen_f(filename,H5F_ACC_RDONLY_F,file_id,hdferr,plist_id)
+#ifdef fMPI
+ call H5Pclose_f(plist_id,hdferr)
+#endif
+ end subroutine h5parse_open_file
+
+ function h5parse_read_dimension_size_for_dataset(dataset_name,dimension) result(dimension_size)
+ ! Return the dimension size for a specific dataset (given by name).
+ ! If the rank of the choosen dataset is > 1, the specific dimension can be selected by number.
+ ! @param[in] dataset_name: The name of the dataset
+ ! @param[in] dimension: The dimension number (default: 1)
+ ! @param[out] dimension_size: Size of the selected dimension in dataset
+ character(len=*), intent(in) :: dataset_name
+ integer, intent(in), optional :: dimension
+ integer :: dimension_size
+ integer(kind=HID_T) :: dataset_id
+ integer(kind=HID_T) :: dataspace_id
+ integer(kind=HSIZE_T), dimension(:), allocatable :: dimsr, maxdimsr
+ integer(kind=4) :: rank
+ integer(kind=4) :: hdferr
+ call H5Dopen_f(file_id,dataset_name,dataset_id,hdferr)
+ ! Open dataset
+ call H5Dget_space_f(dataset_id, dataspace_id, hdferr)
+ ! Get rank
+ call H5Sget_simple_extent_ndims_f(dataspace_id, rank, hdferr)
+ allocate(dimsr(rank))
+ allocate(maxdimsr(rank))
+ ! Get dimension size
+ call H5Sget_simple_extent_dims_f(dataspace_id, dimsr, maxdimsr, hdferr)
+ if (present(dimension)) then
+ dimension_size = int(dimsr(dimension))
+ else
+ dimension_size = int(dimsr(1))
+ end if
+ deallocate(dimsr)
+ deallocate(maxdimsr)
+ call H5Sclose_f(dataspace_id, hdferr)
+ call H5Dclose_f(dataset_id, hdferr)
+ end function h5parse_read_dimension_size_for_dataset
+
+ subroutine h5parse_read_3d_double_dataset(dataset_name,storage,data_shape_ext)
+ ! Read a 3D double dataset
+ ! @param[in] dataset_name: The name of the dataset
+ ! @param[inout] storage: Storage array which will hold the the contents of the dataset
+ ! @param[in] data_shape_ext: Selectable file data_shape (default: shape of storage)
+ character(len=*), intent(in) :: dataset_name
+ double precision, dimension(:,:,:), intent(inout) :: storage
+ integer, optional, dimension(3), intent(in) :: data_shape_ext
+ integer(kind=HSIZE_T), dimension(3) :: data_shape
+ if (present(data_shape_ext)) then
+ data_shape = data_shape_ext
+ else
+ data_shape = shape(storage)
+ end if
+ call h5parse_read_nd_double_dataset(dataset_name,storage,data_shape)
+ end subroutine h5parse_read_3d_double_dataset
+
+ subroutine h5parse_read_3d_integer_dataset(dataset_name,storage,data_shape_ext)
+ ! Read a 3D integer dataset
+ ! @param[in] dataset_name: The name of the dataset
+ ! @param[inout] storage: Storage array which will hold the the contents of the dataset
+ ! @param[in] data_shape_ext: Selectable file data_shape (default: shape of storage)
+ character(len=*), intent(in) :: dataset_name
+ integer, dimension(:,:,:), intent(inout) :: storage
+ integer, optional, dimension(3), intent(in) :: data_shape_ext
+ integer(kind=HSIZE_T), dimension(3) :: data_shape
+ if (present(data_shape_ext)) then
+ data_shape = data_shape_ext
+ else
+ data_shape = shape(storage)
+ end if
+ call h5parse_read_nd_integer_dataset(dataset_name,storage,data_shape)
+ end subroutine h5parse_read_3d_integer_dataset
+
+ subroutine h5parse_read_2d_double_dataset(dataset_name,storage,data_shape_ext)
+ ! Read a 2D double dataset
+ ! @param[in] dataset_name: The name of the dataset
+ ! @param[inout] storage: Storage array which will hold the the contents of the dataset
+ ! @param[in] data_shape_ext: Selectable file data_shape (default: shape of storage)
+ character(len=*), intent(in) :: dataset_name
+ double precision, dimension(:,:), intent(inout) :: storage
+ integer, optional, dimension(2), intent(in) :: data_shape_ext
+ integer(kind=HSIZE_T), dimension(2) :: data_shape
+ if (present(data_shape_ext)) then
+ data_shape = data_shape_ext
+ else
+ data_shape = shape(storage)
+ end if
+ call h5parse_read_nd_double_dataset(dataset_name,storage,data_shape)
+ end subroutine h5parse_read_2d_double_dataset
+
+ subroutine h5parse_read_2d_integer_dataset(dataset_name,storage,data_shape_ext)
+ ! Read a 2D integer dataset
+ ! @param[in] dataset_name: The name of the dataset
+ ! @param[inout] storage: Storage array which will hold the the contents of the dataset
+ ! @param[in] data_shape_ext: Selectable file data_shape (default: shape of storage)
+ character(len=*), intent(in) :: dataset_name
+ integer, dimension(:,:), intent(inout) :: storage
+ integer, optional, dimension(2), intent(in) :: data_shape_ext
+ integer(kind=HSIZE_T), dimension(2) :: data_shape
+ if (present(data_shape_ext)) then
+ data_shape = data_shape_ext
+ else
+ data_shape = shape(storage)
+ end if
+ call h5parse_read_nd_integer_dataset(dataset_name,storage,data_shape)
+ end subroutine h5parse_read_2d_integer_dataset
+
+ subroutine h5parse_read_1d_double_dataset(dataset_name,storage,data_shape_ext)
+ ! Read a 1D double dataset
+ ! @param[in] dataset_name: The name of the dataset
+ ! @param[inout] storage: Storage array which will hold the the contents of the dataset
+ ! @param[in] data_shape_ext: Selectable file data_shape (default: shape of storage)
+ character(len=*), intent(in) :: dataset_name
+ double precision, dimension(:), intent(inout) :: storage
+ integer, optional, intent(in) :: data_shape_ext
+ integer(kind=HSIZE_T), dimension(1) :: data_shape
+ if(present(data_shape_ext))then
+ data_shape = data_shape_ext
+ else
+ data_shape = shape(storage)
+ end if
+ call h5parse_read_nd_double_dataset(dataset_name,storage,data_shape)
+ end subroutine h5parse_read_1d_double_dataset
+
+ subroutine h5parse_read_nd_double_dataset(dataset_name,storage,data_shape)
+ ! Read a nD double dataset
+ ! @param[in] dataset_name: The name of the dataset
+ ! @param[inout] storage: Storage array which will hold the the contents of the dataset
+ ! @param[in] data_shape_ext: Selectable file data_shape (default: shape of storage)
+ character(len=*), intent(in) :: dataset_name
+ double precision, dimension(*), intent(inout) :: storage
+ integer(kind=HSIZE_T), dimension(:), intent(in) :: data_shape
+ integer(kind=HSIZE_T), dimension(:), allocatable :: offset
+ integer(kind=HID_T) :: dataset_id
+ integer(kind=HID_T) :: dataspace_id, memspace_id
+ integer(kind=4) :: hdferr
+ allocate(offset(size(data_shape)))
+ offset = 0
+ call H5Dopen_f(file_id, dataset_name, dataset_id, hdferr)
+ ! Open dataset
+ call H5Dget_space_f(dataset_id, dataspace_id, hdferr)
+ ! Select data_shape in dataset
+ call H5Sselect_hyperslab_f(dataspace_id, H5S_SELECT_SET_F, offset, data_shape, hdferr)
+ ! Create memory dataspace
+ call H5Screate_simple_f(size(data_shape), data_shape, memspace_id, hdferr)
+ ! Read the data
+ call H5Dread_f(dataset_id, H5T_NATIVE_DOUBLE, storage, data_shape, hdferr, &
+ & memspace_id, dataspace_id)
+ call H5Sclose_f(memspace_id, hdferr)
+ call H5Sclose_f(dataspace_id, hdferr)
+ call H5Dclose_f(dataset_id, hdferr)
+ deallocate(offset)
+ end subroutine h5parse_read_nd_double_dataset
+
+ subroutine h5parse_read_nd_integer_dataset(dataset_name,storage,data_shape)
+ ! Read a nD integer dataset
+ ! @param[in] dataset_name: The name of the dataset
+ ! @param[inout] storage: Storage array which will hold the the contents of the dataset
+ ! @param[in] data_shape_ext: Selectable file data_shape (default: shape of storage)
+ character(len=*), intent(in) :: dataset_name
+ integer, dimension(*), intent(inout) :: storage
+ integer(kind=HSIZE_T), dimension(:), intent(in) :: data_shape
+ integer(kind=HSIZE_T), dimension(:), allocatable :: offset
+ integer(kind=HID_T) :: dataset_id
+ integer(kind=HID_T) :: dataspace_id, memspace_id
+ integer(kind=4) :: hdferr
+ allocate(offset(size(data_shape)))
+ offset = 0
+ call H5Dopen_f(file_id,dataset_name,dataset_id,hdferr)
+ ! Open dataset
+ call H5Dget_space_f(dataset_id, dataspace_id, hdferr)
+ ! Select data_shape in dataset
+ call H5Sselect_hyperslab_f(dataspace_id, H5S_SELECT_SET_F, offset, data_shape, hdferr)
+ ! Create memory dataspace
+ call H5Screate_simple_f(size(data_shape), data_shape, memspace_id, hdferr)
+ ! Read the data
+ call H5Dread_f(dataset_id, H5T_NATIVE_INTEGER, storage, data_shape, hdferr, &
+ & memspace_id, dataspace_id)
+ call H5Sclose_f(memspace_id, hdferr)
+ call H5Sclose_f(dataspace_id, hdferr)
+ call H5Dclose_f(dataset_id, hdferr)
+ deallocate(offset)
+ end subroutine h5parse_read_nd_integer_dataset
+
+ function h5parse_check_attr_exist(attr_name,obj_name_ext) result(attr_exists)
+ ! Check if a specifc attribute, given by name, exists
+ ! @param[in] attr_name: The name of the attribute
+ ! @param[in] obj_name_ext: The relative context the attribute belongs to (default: root)
+ ! @param[out] attr_exists: Attribute exists?
+ character(len=*), intent(in) :: attr_name
+ character(len=*), optional, intent(in) :: obj_name_ext
+ character(len=255) :: obj_name
+ logical(kind=4) :: attr_exists
+ integer(kind=4) :: hdferr
+ if(present(obj_name_ext)) then
+ obj_name = obj_name_ext
+ else
+ obj_name = "/"
+ end if
+ call h5aexists_by_name_f(file_id, obj_name, attr_name, attr_exists, hdferr)
+ end function h5parse_check_attr_exist
+
+ function h5parse_check_dataset_exist(dataset_name) result(dataset_exists)
+ ! Check if a specifc dataset, given by name, exists
+ ! @param[in] dataset_name: The name of the dataset
+ ! @param[out] dataset_exists: Dataset exists?
+ character(len=*), intent(in) :: dataset_name
+ logical(kind=4) :: dataset_exists
+ integer(kind=4) :: hdferr
+ call h5lexists_f(file_id, dataset_name, dataset_exists, hdferr)
+ end function h5parse_check_dataset_exist
+
+ subroutine h5parse_read_double_attribute(attr_name,storage,obj_name_ext)
+ ! Read the content of a double attribute
+ ! @param[in] attr_name: The name of the attribute
+ ! @param[in] obj_name_ext: The relative context the attribute belongs to (default: root)
+ ! @param[inout] storage: Storage variable which will hold the the content of the attribute
+ character(len=*), intent(in) :: attr_name
+ double precision, intent(inout) :: storage
+ character(len=*), optional, intent(in) :: obj_name_ext
+ character(len=255) :: obj_name
+ integer(kind=4) :: hdferr
+ integer(kind=HID_T) :: attr_id
+ integer(kind=HSIZE_T), dimension(1) :: dims = 0
+ if(present(obj_name_ext)) then
+ obj_name = obj_name_ext
+ else
+ obj_name = "/"
+ end if
+ call h5aopen_by_name_f(file_id, obj_name, attr_name, attr_id, hdferr)
+ call h5aread_f(attr_id, H5T_NATIVE_DOUBLE, storage, dims, hdferr)
+ call h5aclose_f(attr_id, hdferr)
+ end subroutine h5parse_read_double_attribute
+
+ subroutine h5parse_read_integer_attribute(attr_name,storage,obj_name_ext)
+ ! Read the content of a integer attribute
+ ! @param[in] attr_name: The name of the attribute
+ ! @param[in] obj_name_ext: The relative context the attribute belongs to (default: root)
+ ! @param[inout] storage: Storage variable which will hold the the content of the attribute
+ character(len=*), intent(in) :: attr_name
+ integer, intent(inout) :: storage
+ character(len=*), optional, intent(in) :: obj_name_ext
+ character(len=255) :: obj_name
+ integer(kind=4) :: hdferr
+ integer(kind=HID_T) :: attr_id
+ integer(kind=HSIZE_T), dimension(1) :: dims = 0
+ if(present(obj_name_ext)) then
+ obj_name = obj_name_ext
+ else
+ obj_name = "/"
+ end if
+ call h5aopen_by_name_f(file_id, obj_name, attr_name, attr_id, hdferr)
+ call h5aread_f(attr_id, H5T_NATIVE_INTEGER, storage, dims, hdferr)
+ call h5aclose_f(attr_id, hdferr)
+ end subroutine h5parse_read_integer_attribute
+
+ subroutine h5parse_close_file()
+ ! Close the HDF5 internal file handle
+ integer(kind=4) :: hdferr
+ call H5Fclose_f(file_id, hdferr)
+ end subroutine h5parse_close_file
+
+ subroutine h5parse_finalize()
+ ! Close the HDF5 Fortran interface
+ integer(kind=4) :: hdferr
+ h5parse_hdf5_environment = .false.
+ call H5close_f(hdferr)
+ end subroutine h5parse_finalize
+
+ subroutine h5parse_open_datafile(filename)
+ ! Find the HDF5 datafile filenam in the standard ASCII input file
+ ! @param[in] filename: Name of the standard ASCII input file
+ use mod_genrl
+ character(len=*), intent(in) :: filename
+ character(len=255) :: hdf5_data_filename
+ character(len=80) :: line
+ logical :: found
+ integer :: lblank
+ open(79,file=filename,status='old')
+ call h5parse_init()
+ ! Search for the HDF5 datafile filename
+ if (found(79,key_char//' h5parse data file',line,.false.)) then
+ read(79,'(1A)',err=200,end=200) hdf5_data_filename
+ write(*,*) ' '
+ write(*,*) ' reading model input data:'
+ write(*,*) ' from file "', hdf5_data_filename(&
+ &:lblank(hdf5_data_filename)),'"'
+ write(*,*) ' '
+ ! Use HDF5 input file parser
+ h5parse_use_hdf5_datafile = .true.
+ ! Open the datafile
+ call h5parse_open_file(hdf5_data_filename)
+ else
+ ! Do not use HDF5 input file parser (use old input format)
+ h5parse_use_hdf5_datafile = .false.
+ end if
+ close(79)
+ return
+200 write(*,'(1A)') 'error: can not read "h5parse data file"!'
+ stop
+ end subroutine h5parse_open_datafile
+
+ subroutine h5parse_close_datafile()
+ ! Close the HDF5 internal file handle and the HDF5 interface
+ if (h5parse_use_hdf5_datafile) then
+ call h5parse_close_file()
+ h5parse_use_hdf5_datafile = .false.
+ end if
+ call h5parse_finalize()
+ end subroutine h5parse_close_datafile
+#endif
+
+end module mod_input_file_parser_hdf5
diff --git a/hdf5/open_hdf5.f90 b/hdf5/open_hdf5.f90
new file mode 100644
index 0000000..9f48757
--- /dev/null
+++ b/hdf5/open_hdf5.f90
@@ -0,0 +1,60 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief open hdf5-file
+!> @param[in] f_name hdf5 file name
+!> @details
+!> Opening hdf5 files, used in read-routines.
+!> Note: To be able to use input file parsing with hdf5, the
+!> hdf5-input-files have to be generated using the script:
+!> `convert_to_hdf5.py`. This script can be found in the repository
+!> `SHEMAT-Suite_Scripts` under
+!> `python/preprocessing/convert_to_hdf5.py`.
+ SUBROUTINE open_hdf5(f_name)
+#ifndef noHDF
+ USE hdf5
+ use mod_input_file_parser_hdf5
+ use mod_hdf5_vars, only: default_hdf_file, file_id, error
+#endif
+ IMPLICIT NONE
+
+! arrayname and filename
+ character (len=*) :: f_name
+
+
+#ifndef noHDF
+
+! Initialize FORTRAN interface.
+ if (.not. h5parse_hdf5_environment) then
+ CALL h5open_f(error)
+ end if
+
+! Reopen hdf5 file.
+ default_hdf_file = f_name
+ IF (f_name/=' ') THEN
+ CALL h5fopen_f(f_name,h5f_acc_rdwr_f,file_id,error)
+ END IF
+
+#endif
+ RETURN
+ END
+
diff --git a/hdf5/read_hdf5.f90 b/hdf5/read_hdf5.f90
new file mode 100644
index 0000000..a661393
--- /dev/null
+++ b/hdf5/read_hdf5.f90
@@ -0,0 +1,117 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+! ******************************************************
+! WARNING: need 32 Bit version of the HDF5 library !
+! ******************************************************
+
+!> @brief reads an 3-dimensional array HDF5 file
+!> @param[in] NI 1.dimension
+!> @param[in] NJ 2.dimension
+!> @param[in] NK 3.dimension
+!> @param[in] A_name array name
+!> @param[in] f_name hdf5 file name
+!> @param[out] A double precision array with all readed data
+!> @details
+!> This routine is used to open external hdf5 files specified in
+!> the SHEMAT-Suite input file and read a double precision array.
+ SUBROUTINE read_hdf5(ni,nj,nk,a,a_name,f_name)
+#ifndef noHDF
+ USE hdf5
+ use mod_hdf5_vars, only: file_id, error
+#endif
+ use mod_linfos
+ IMPLICIT NONE
+
+! arrayname and filename
+ character (len=*) :: a_name, f_name
+
+ INTEGER ni, nj, nk
+ DOUBLE PRECISION a(ni,nj,nk)
+
+#ifndef noHDF
+! Dataset identifier
+ INTEGER (hid_t) dset_id
+
+! Data type identifier
+ INTEGER (hid_t) dtype_id
+#endif
+
+#ifndef noHDF
+! Data buffers
+ INTEGER (hsize_t) data_dims(7)
+#endif
+
+#ifndef noHDF
+
+ data_dims(1) = ni
+ data_dims(2) = nj
+ data_dims(3) = nk
+
+! Open hdf5 file if closed
+ CALL closeopen_hdf5(f_name)
+
+! Access dataset 'A' in the first file under 'A_name' name.
+ CALL h5dopen_f(file_id,a_name,dset_id,error)
+
+ IF (error/=0) THEN
+ WRITE(*,*)
+ WRITE(*,'(5A)') 'error: no array "', a_name, &
+ '" on the file "', f_name, '" !!!'
+ IF (a_name=='head') THEN
+ WRITE(*,'(2A)') '*** May be an old "phi" style file,', &
+ ' then change it to "head" ! ***'
+ WRITE(*,'(1A)') ' -> try to find "phi" ...'
+ WRITE(*,*)
+ CALL h5dopen_f(file_id,'phi',dset_id,error)
+ GO TO 300
+ END IF
+ WRITE(*,*)
+ STOP
+ END IF
+300 CONTINUE
+
+! Get dataset's data type.
+ CALL h5dget_type_f(dset_id,dtype_id,error)
+
+! Read the dataset in 'A'.
+!AW call h5dread_f(dset_id, dtype_id, A, data_dims, error)
+ CALL h5dread_f(dset_id,h5t_native_double,a,data_dims,error)
+
+ IF (error/=0) THEN
+ WRITE(*,'(5A)') 'error: can not read the array "', a_name, &
+ '" on the file "', f_name, '" !'
+ STOP
+ END IF
+
+! Close file, dataset and dataspace identifiers.
+ CALL h5dclose_f(dset_id,error)
+ CALL h5tclose_f(dtype_id,error)
+
+ IF (linfos(1)>=1) WRITE(*,*) ' open HDF5 file: ', f_name
+
+#else
+ WRITE(*,*) 'error: HDF5 support was not compiled in'
+ STOP
+#endif
+ RETURN
+ END
diff --git a/hdf5/read_hdf5_int.f90 b/hdf5/read_hdf5_int.f90
new file mode 100644
index 0000000..ed2b74e
--- /dev/null
+++ b/hdf5/read_hdf5_int.f90
@@ -0,0 +1,127 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief reads an 3-dimensional array from an opened HDF5 file
+!> @param[in] NI 1.dimension
+!> @param[in] NJ 2.dimension
+!> @param[in] NK 3.dimension
+!> @param[in] A_name array name
+!> @param[in] f_name hdf5 file name
+!> @param[out] A integer array with all readed data
+!> This routine is used to open external hdf5 files specified in
+!> the SHEMAT-Suite input file and read a integer array.
+ SUBROUTINE read_hdf5_int(ni,nj,nk,a,a_name,f_name)
+#ifndef noHDF
+ USE hdf5
+ use mod_hdf5_vars, only: file_id, error
+#endif
+ use mod_linfos
+ IMPLICIT NONE
+
+! arrayname and filename
+ character (len=*) :: a_name, f_name
+
+ INTEGER ni, nj, nk, i, j, k
+ INTEGER a(ni,nj,nk)
+
+#ifndef noHDF
+! Dataset identifier
+ INTEGER (hid_t) dset_id
+
+! Data type identifier
+ INTEGER (hid_t) dtype_id
+#endif
+
+#ifndef noHDF
+! Data buffers
+ INTEGER (hsize_t) data_dims(7)
+#endif
+
+! for 32Bit HDF5 library
+#ifdef HDF6432
+ INTEGER (kind=4), allocatable :: inttmp(:,:,:)
+#else
+#ifdef HDF64
+ INTEGER (kind=8), allocatable :: inttmp(:,:,:)
+#else
+ INTEGER, ALLOCATABLE :: inttmp(:,:,:)
+#endif
+#endif
+
+#ifndef noHDF
+
+ ALLOCATE(inttmp(ni,nj,nk))
+
+ data_dims(1) = ni
+ data_dims(2) = nj
+ data_dims(3) = nk
+
+! Open hdf5 file if closed
+ CALL closeopen_hdf5(f_name)
+
+! Access dataset 'A' in the first file under 'A_name' name.
+ CALL h5dopen_f(file_id,a_name,dset_id,error)
+
+ IF (error/=0) THEN
+ WRITE(*,*)
+ WRITE(*,'(5A)') 'error: no array "', a_name, &
+ '" on the file "', f_name, '" !!!'
+ WRITE(*,*)
+ STOP
+ END IF
+
+! Get dataset's data type.
+ CALL h5dget_type_f(dset_id,dtype_id,error)
+
+! Read the dataset in 'A'.
+!AW call h5dread_f(dset_id, dtype_id, A, data_dims, error)
+ CALL h5dread_f(dset_id,h5t_native_integer,inttmp,data_dims, &
+ error)
+
+ IF (error/=0) THEN
+ WRITE(*,'(5A)') 'error: can not read the array "', a_name, &
+ '" on the file "', f_name, '" !'
+ STOP
+ END IF
+
+! Close file, dataset and dataspace identifiers.
+ CALL h5dclose_f(dset_id,error)
+ CALL h5tclose_f(dtype_id,error)
+ DO k = 1, nk
+ DO j = 1, nj
+ DO i = 1, ni
+ a(i,j,k) = inttmp(i,j,k)
+ END DO
+ END DO
+ END DO
+
+ DEALLOCATE(inttmp)
+
+ IF (linfos(1)>=1) WRITE(*,*) ' open HDF5 file: ', f_name
+
+#else
+ WRITE(*,*) 'error: HDF5 support was not compiled in'
+ STOP
+#endif
+ RETURN
+ END
+
diff --git a/hdf5/test_hdf5.f90 b/hdf5/test_hdf5.f90
new file mode 100644
index 0000000..182cdb1
--- /dev/null
+++ b/hdf5/test_hdf5.f90
@@ -0,0 +1,32 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief flag function (HDF5 enabled)
+!> @return logical switch for hdf environment variable
+ LOGICAL FUNCTION test_hdf5()
+#ifndef noHDF
+ test_hdf5 = .TRUE.
+#else
+ test_hdf5 = .FALSE.
+#endif
+ RETURN
+ END
diff --git a/hdf5/write_all_hdf5.f90 b/hdf5/write_all_hdf5.f90
new file mode 100644
index 0000000..4fe5770
--- /dev/null
+++ b/hdf5/write_all_hdf5.f90
@@ -0,0 +1,698 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+! ******************************************************
+! WARNING: need 32 Bit version of the HDF5 library !
+! ******************************************************
+
+!> @brief write out the physical state and all properties
+!> @param[in] ident file/iteration index number
+!> @param[in] ismpl local sample index
+!> @details
+!> create an hdf5 output file\n
+ SUBROUTINE write_hdf(ident,ismpl)
+#ifndef noHDF
+ USE hdf5
+ use mod_hdf5_vars, only: error
+#endif
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_flow
+ use mod_temp
+ use mod_conc
+ use mod_time
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+ double precision :: dx, dy, dz
+ integer :: i1s, i2s, i1, i2, i3, i4, ident
+
+ double precision, external :: vxc, vyc, vzc, kx, ky, kz, lx, ly, lz, por, &
+ rhof, visf
+
+ character (len=80) :: filename
+ character (len=8) :: snumber
+
+ logical, dimension (3) :: out_bc
+
+#ifndef noHDF
+! File identifiers
+ integer (kind=hid_t) :: file_id
+
+! Dataset identifier
+ integer (kind=hid_t) :: dset_id
+
+! Data space identifier
+ integer (kind=hid_t) :: dataspace
+#endif
+
+#ifdef HDF6432
+! need for 32Bit HDF5 library
+ INTEGER (kind=4) :: rank
+ INTEGER (kind=4) :: gzlevel
+ INTEGER (kind=4), allocatable :: inttmp(:,:,:)
+#else
+#ifdef HDF64
+ INTEGER (kind=8) :: rank
+ INTEGER (kind=8) :: gzlevel
+ INTEGER (kind=8), allocatable :: inttmp(:,:,:)
+#else
+ integer :: rank
+ integer :: gzlevel
+ integer, allocatable, dimension (:,:,:) :: inttmp
+#endif
+#endif
+ PARAMETER (rank=3)
+
+! gzip compression level
+ PARAMETER (gzlevel=9)
+
+#ifndef noHDF
+! Data buffers
+ integer (kind=hsize_t), dimension (rank) :: dims
+ integer (kind=hsize_t), dimension (7) :: data_dims
+
+! for chunk size and compression
+ integer (kind=hid_t) :: plist_id
+ integer (kind=hsize_t), dimension (rank) :: chunk_dims
+#endif
+
+ DOUBLE PRECISION, ALLOCATABLE :: dp3tmp(:,:,:), &
+ dp4tmp(:,:,:,:)
+
+! bc-naming
+ character (len=3), dimension (2) :: c_bt
+ DATA c_bt/'bcd', 'bcn'/
+ character (len=8) :: c_name
+
+ integer, external :: lblank
+
+#ifndef noHDF
+
+#ifdef NOOUT
+ RETURN
+#endif
+
+ CALL chln(project,i1,i2)
+ CALL chln(project_sfx(ismpl),i1s,i2s)
+ IF (ident>=0) THEN
+ WRITE(snumber,'(1I7)') ident
+ ELSE IF (ident==-1) THEN
+ WRITE(snumber,'(A8)') 'final'
+ ELSE IF (ident==-2) THEN
+ WRITE(snumber,'(A8)') 'debug'
+ ELSE IF (ident==-3) THEN
+ WRITE(snumber,'(A8)') 'ens_mean'
+ ELSE IF (ident==-4) THEN
+ WRITE(snumber,'(A8)') 'mean'
+ ELSE IF (ident==-5) THEN
+ WRITE(snumber,'(A8)') 'ens_mean'
+ END IF
+ CALL chln(snumber,i3,i4)
+ IF (i1s==0) THEN
+ filename = project(i1:i2) // '_' // snumber(i3:i4) // '.h5'
+ ELSE
+ filename = project(i1:i2) // project_sfx(ismpl) (i1s:i2s) // &
+ '_' // snumber(i3:i4) // '.h5'
+ END IF
+
+ IF (linfos(3)>=1) THEN
+ WRITE(*,'(3A)') ' [W] : HDF5 to "', &
+ filename(1:lblank(filename)), '"'
+ END IF
+
+
+#ifdef fOMP
+!$OMP critical
+#endif
+! Initialize FORTRAN interface.
+ CALL h5open_f(error)
+
+! Create a new file, later only open it for read and writes
+ CALL h5fcreate_f(filename,h5f_acc_trunc_f,file_id,error, &
+ h5p_default_f,h5p_default_f)
+
+ dims(1) = i0
+ dims(2) = j0
+ dims(3) = k0
+ data_dims(1) = i0
+ data_dims(2) = j0
+ data_dims(3) = k0
+ chunk_dims(1) = min(20,i0)
+ chunk_dims(2) = min(20,j0)
+ chunk_dims(3) = min(20,k0)
+
+! for compression only
+ CALL h5pcreate_f(h5p_dataset_create_f,plist_id,error)
+ CALL h5pset_chunk_f(plist_id,rank,chunk_dims,error)
+ CALL h5pset_deflate_f(plist_id,gzlevel,error)
+
+ ALLOCATE(inttmp(i0,j0,k0))
+ ALLOCATE(dp4tmp(i0,j0,k0,7))
+! not very performant !!!
+ DO i3 = 1, k0
+ dz = delza(i3)
+ DO i2 = 1, j0
+ dy = delya(i2)
+ DO i1 = 1, i0
+ dx = delxa(i1)
+ dp4tmp(i1,i2,i3,1) = dx
+ dp4tmp(i1,i2,i3,2) = dy
+ dp4tmp(i1,i2,i3,3) = dz
+ dp4tmp(i1,i2,i3,4) = vxc(i1,i2,i3,ismpl)
+ dp4tmp(i1,i2,i3,5) = vyc(i1,i2,i3,ismpl)
+ dp4tmp(i1,i2,i3,6) = vzc(i1,i2,i3,ismpl)
+ END DO
+ END DO
+ END DO
+
+ IF (ident<=-1 .OR. out_ijk(cout_i)) THEN
+! Create data space for the dataset.
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+! Create dataset "A" inside file "f_name".
+ CALL h5dcreate_f(file_id,'x',h5t_native_double,dataspace, &
+ dset_id,error,plist_id)
+! Write 'A' to the dataset
+ CALL h5dwrite_f(dset_id,h5t_native_double,dp4tmp(1,1,1,1), &
+ data_dims,error)
+! Close file, dataset and dataspace identifiers.
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END IF
+
+ IF (ident<=-1 .OR. out_ijk(cout_j)) THEN
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+ CALL h5dcreate_f(file_id,'y',h5t_native_double,dataspace, &
+ dset_id,error,plist_id)
+ CALL h5dwrite_f(dset_id,h5t_native_double,dp4tmp(1,1,1,2), &
+ data_dims,error)
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END IF
+
+ IF (ident<=-1 .OR. out_ijk(cout_k)) THEN
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+ CALL h5dcreate_f(file_id,'z',h5t_native_double,dataspace, &
+ dset_id,error,plist_id)
+ CALL h5dwrite_f(dset_id,h5t_native_double,dp4tmp(1,1,1,3), &
+ data_dims,error)
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END IF
+
+ DO i3 = 1, k0
+ DO i2 = 1, j0
+ DO i1 = 1, i0
+ inttmp(i1,i2,i3) = uindex(i1,i2,i3)
+ END DO
+ END DO
+ END DO
+ IF (ident<=-1 .OR. out_ijk(cout_uindex)) THEN
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+ CALL h5dcreate_f(file_id,'uindex',h5t_native_integer, &
+ dataspace,dset_id,error,plist_id)
+ CALL h5dwrite_f(dset_id,h5t_native_integer,inttmp,data_dims, &
+ error)
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END IF
+
+! - main arrays -
+ IF (ident<=-1 .OR. out_pv(pv_head)) THEN
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+ CALL h5dcreate_f(file_id,'head',h5t_native_double,dataspace, &
+ dset_id,error,plist_id)
+ CALL h5dwrite_f(dset_id,h5t_native_double,head(1,1,1,ismpl), &
+ data_dims,error)
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END IF
+
+ IF (ident<=-1 .OR. out_pv(pv_temp)) THEN
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+ CALL h5dcreate_f(file_id,'temp',h5t_native_double,dataspace, &
+ dset_id,error,plist_id)
+ CALL h5dwrite_f(dset_id,h5t_native_double,temp(1,1,1,ismpl), &
+ data_dims,error)
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END IF
+
+ IF (ident<=-1 .OR. out_pv(pv_pres)) THEN
+! convert [Pa] into [MPa]
+ DO i3 = 1, k0
+ DO i2 = 1, j0
+ DO i1 = 1, i0
+ x(i1,i2,i3,ismpl) = pres(i1,i2,i3,ismpl)*pa_conv1
+ END DO
+ END DO
+ END DO
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+ CALL h5dcreate_f(file_id,'pres',h5t_native_double,dataspace, &
+ dset_id,error,plist_id)
+ CALL h5dwrite_f(dset_id,h5t_native_double,x(1,1,1,ismpl), &
+ data_dims,error)
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END IF
+
+ IF ((ident<=-1 .OR. out_pv(pv_conc)) .AND. trans_active) THEN
+ DO i = 1, ntrans
+ WRITE(snumber,'(1A4,1I4.4)') 'conc', i
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+ CALL h5dcreate_f(file_id,snumber,h5t_native_double, &
+ dataspace,dset_id,error,plist_id)
+ CALL h5dwrite_f(dset_id,h5t_native_double, &
+ conc(1,1,1,i,ismpl),data_dims,error)
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END DO
+ END IF
+
+! ---------------
+
+ IF (ident<=-1 .OR. out_ijk(cout_vx)) THEN
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+ CALL h5dcreate_f(file_id,'vx',h5t_native_double,dataspace, &
+ dset_id,error,plist_id)
+ CALL h5dwrite_f(dset_id,h5t_native_double,dp4tmp(1,1,1,4), &
+ data_dims,error)
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END IF
+
+ IF (ident<=-1 .OR. out_ijk(cout_vy)) THEN
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+ CALL h5dcreate_f(file_id,'vy',h5t_native_double,dataspace, &
+ dset_id,error,plist_id)
+ CALL h5dwrite_f(dset_id,h5t_native_double,dp4tmp(1,1,1,5), &
+ data_dims,error)
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END IF
+
+ IF (ident<=-1 .OR. out_ijk(cout_vz)) THEN
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+ CALL h5dcreate_f(file_id,'vz',h5t_native_double,dataspace, &
+ dset_id,error,plist_id)
+ CALL h5dwrite_f(dset_id,h5t_native_double,dp4tmp(1,1,1,6), &
+ data_dims,error)
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END IF
+
+
+ DO i3 = 1, k0
+ DO i2 = 1, j0
+ DO i1 = 1, i0
+ dp4tmp(i1,i2,i3,7) = por(i1,i2,i3,ismpl)
+ END DO
+ END DO
+ END DO
+ IF (ident<=-1 .OR. out_prop(idx_por)) THEN
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+ CALL h5dcreate_f(file_id,'por',h5t_native_double,dataspace, &
+ dset_id,error,plist_id)
+ CALL h5dwrite_f(dset_id,h5t_native_double,dp4tmp(1,1,1,7), &
+ data_dims,error)
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END IF
+
+ DO i3 = 1, k0
+ DO i2 = 1, j0
+ DO i1 = 1, i0
+ dp4tmp(i1,i2,i3,1) = kx(i1,i2,i3,ismpl)
+ dp4tmp(i1,i2,i3,2) = ky(i1,i2,i3,ismpl)
+ dp4tmp(i1,i2,i3,3) = kz(i1,i2,i3,ismpl)
+ dp4tmp(i1,i2,i3,4) = lx(i1,i2,i3,ismpl)
+ dp4tmp(i1,i2,i3,5) = ly(i1,i2,i3,ismpl)
+ dp4tmp(i1,i2,i3,6) = lz(i1,i2,i3,ismpl)
+ END DO
+ END DO
+ END DO
+ IF (ident<=-1 .OR. out_prop(idx_an_kx)) THEN
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+ CALL h5dcreate_f(file_id,'kx',h5t_native_double,dataspace, &
+ dset_id,error,plist_id)
+ CALL h5dwrite_f(dset_id,h5t_native_double,dp4tmp(1,1,1,1), &
+ data_dims,error)
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END IF
+
+ IF (ident<=-1 .OR. out_prop(idx_an_ky)) THEN
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+ CALL h5dcreate_f(file_id,'ky',h5t_native_double,dataspace, &
+ dset_id,error,plist_id)
+ CALL h5dwrite_f(dset_id,h5t_native_double,dp4tmp(1,1,1,2), &
+ data_dims,error)
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END IF
+
+ IF (ident<=-1 .OR. out_prop(idx_kz)) THEN
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+ CALL h5dcreate_f(file_id,'kz',h5t_native_double,dataspace, &
+ dset_id,error,plist_id)
+ CALL h5dwrite_f(dset_id,h5t_native_double,dp4tmp(1,1,1,3), &
+ data_dims,error)
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END IF
+
+ IF (ident<=-1 .OR. out_prop(idx_an_lx)) THEN
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+ CALL h5dcreate_f(file_id,'lx',h5t_native_double,dataspace, &
+ dset_id,error,plist_id)
+ CALL h5dwrite_f(dset_id,h5t_native_double,dp4tmp(1,1,1,4), &
+ data_dims,error)
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END IF
+
+ IF (ident<=-1 .OR. out_prop(idx_an_ly)) THEN
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+ CALL h5dcreate_f(file_id,'ly',h5t_native_double,dataspace, &
+ dset_id,error,plist_id)
+ CALL h5dwrite_f(dset_id,h5t_native_double,dp4tmp(1,1,1,5), &
+ data_dims,error)
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END IF
+
+ IF (ident<=-1 .OR. out_prop(idx_lz)) THEN
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+ CALL h5dcreate_f(file_id,'lz',h5t_native_double,dataspace, &
+ dset_id,error,plist_id)
+ CALL h5dwrite_f(dset_id,h5t_native_double,dp4tmp(1,1,1,6), &
+ data_dims,error)
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END IF
+
+ DO i3 = 1, k0
+ DO i2 = 1, j0
+ DO i1 = 1, i0
+ i = uindex(i1,i2,i3)
+ dp4tmp(i1,i2,i3,1) = propunit(i,idx_comp,ismpl)
+ dp4tmp(i1,i2,i3,2) = propunit(i,idx_q,ismpl)
+ dp4tmp(i1,i2,i3,3) = propunit(i,idx_rc,ismpl)
+ dp4tmp(i1,i2,i3,4) = propunit(i,idx_df,ismpl)
+ dp4tmp(i1,i2,i3,5) = propunit(i,idx_ec,ismpl)
+ dp4tmp(i1,i2,i3,6) = propunit(i,idx_lc,ismpl)
+ END DO
+ END DO
+ END DO
+
+ IF (ident<=-1 .OR. out_prop(idx_comp)) THEN
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+ CALL h5dcreate_f(file_id,'comp',h5t_native_double,dataspace, &
+ dset_id,error,plist_id)
+ CALL h5dwrite_f(dset_id,h5t_native_double,dp4tmp(1,1,1,1), &
+ data_dims,error)
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END IF
+
+ IF (ident<=-1 .OR. out_prop(idx_q)) THEN
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+ CALL h5dcreate_f(file_id,'q',h5t_native_double,dataspace, &
+ dset_id,error,plist_id)
+ CALL h5dwrite_f(dset_id,h5t_native_double,dp4tmp(1,1,1,2), &
+ data_dims,error)
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END IF
+
+ IF (ident<=-1 .OR. out_prop(idx_rc)) THEN
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+ CALL h5dcreate_f(file_id,'rc',h5t_native_double,dataspace, &
+ dset_id,error,plist_id)
+ CALL h5dwrite_f(dset_id,h5t_native_double,dp4tmp(1,1,1,3), &
+ data_dims,error)
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END IF
+
+ IF (ident<=-1 .OR. out_prop(idx_df)) THEN
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+ CALL h5dcreate_f(file_id,'df',h5t_native_double,dataspace, &
+ dset_id,error,plist_id)
+ CALL h5dwrite_f(dset_id,h5t_native_double,dp4tmp(1,1,1,4), &
+ data_dims,error)
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END IF
+
+ IF (ident<=-1 .OR. out_prop(idx_ec)) THEN
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+ CALL h5dcreate_f(file_id,'ec',h5t_native_double,dataspace, &
+ dset_id,error,plist_id)
+ CALL h5dwrite_f(dset_id,h5t_native_double,dp4tmp(1,1,1,5), &
+ data_dims,error)
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END IF
+
+ IF (ident<=-1 .OR. out_prop(idx_lc)) THEN
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+ CALL h5dcreate_f(file_id,'lc',h5t_native_double,dataspace, &
+ dset_id,error,plist_id)
+ CALL h5dwrite_f(dset_id,h5t_native_double,dp4tmp(1,1,1,6), &
+ data_dims,error)
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END IF
+
+
+ DO i3 = 1, k0
+ DO i2 = 1, j0
+ DO i1 = 1, i0
+ dp4tmp(i1,i2,i3,1) = rhof(i1,i2,i3,ismpl)
+ dp4tmp(i1,i2,i3,2) = visf(i1,i2,i3,ismpl)
+ END DO
+ END DO
+ END DO
+ IF (ident<=-1 .OR. out_ijk(cout_rhof)) THEN
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+ CALL h5dcreate_f(file_id,'rhof',h5t_native_double,dataspace, &
+ dset_id,error,plist_id)
+ CALL h5dwrite_f(dset_id,h5t_native_double,dp4tmp(1,1,1,1), &
+ data_dims,error)
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END IF
+
+ IF (ident<=-1 .OR. out_ijk(cout_visf)) THEN
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+ CALL h5dcreate_f(file_id,'visf',h5t_native_double,dataspace, &
+ dset_id,error,plist_id)
+ CALL h5dwrite_f(dset_id,h5t_native_double,dp4tmp(1,1,1,2), &
+ data_dims,error)
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END IF
+
+ dims(1) = i0
+ dims(2) = 1
+ dims(3) = 1
+ data_dims(1) = i0
+ data_dims(2) = 1
+ data_dims(3) = 1
+ chunk_dims(1) = min(8000,i0)
+ chunk_dims(2) = 1
+ chunk_dims(3) = 1
+! for compression only
+ CALL h5pclose_f(plist_id,error)
+ CALL h5pcreate_f(h5p_dataset_create_f,plist_id,error)
+ CALL h5pset_chunk_f(plist_id,rank,chunk_dims,error)
+ CALL h5pset_deflate_f(plist_id,gzlevel,error)
+
+ IF (out_ijk(cout_i)) THEN
+! Create data space for the dataset.
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+! Create dataset "A" inside file "f_name".
+ CALL h5dcreate_f(file_id,'delx',h5t_native_double,dataspace, &
+ dset_id,error,plist_id)
+! Write 'A' to the dataset
+ CALL h5dwrite_f(dset_id,h5t_native_double,delx,data_dims, &
+ error)
+! Close file, dataset and dataspace identifiers.
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END IF
+
+ dims(1) = 1
+ dims(2) = j0
+ dims(3) = 1
+ data_dims(1) = 1
+ data_dims(2) = j0
+ data_dims(3) = 1
+ chunk_dims(1) = 1
+ chunk_dims(2) = min(8000,j0)
+ chunk_dims(3) = 1
+! for compression only
+ CALL h5pclose_f(plist_id,error)
+ CALL h5pcreate_f(h5p_dataset_create_f,plist_id,error)
+ CALL h5pset_chunk_f(plist_id,rank,chunk_dims,error)
+ CALL h5pset_deflate_f(plist_id,gzlevel,error)
+
+ IF (out_ijk(cout_j)) THEN
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+ CALL h5dcreate_f(file_id,'dely',h5t_native_double,dataspace, &
+ dset_id,error,plist_id)
+ CALL h5dwrite_f(dset_id,h5t_native_double,dely,data_dims, &
+ error)
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END IF
+
+ dims(1) = 1
+ dims(2) = 1
+ dims(3) = k0
+ data_dims(1) = 1
+ data_dims(2) = 1
+ data_dims(3) = k0
+ chunk_dims(1) = 1
+ chunk_dims(2) = 1
+ chunk_dims(3) = min(8000,k0)
+! for compression only
+ CALL h5pclose_f(plist_id,error)
+ CALL h5pcreate_f(h5p_dataset_create_f,plist_id,error)
+ CALL h5pset_chunk_f(plist_id,rank,chunk_dims,error)
+ CALL h5pset_deflate_f(plist_id,gzlevel,error)
+
+ IF (out_ijk(cout_k)) THEN
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+ CALL h5dcreate_f(file_id,'delz',h5t_native_double,dataspace, &
+ dset_id,error,plist_id)
+ CALL h5dwrite_f(dset_id,h5t_native_double,delz,data_dims, &
+ error)
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END IF
+
+ DEALLOCATE(inttmp)
+ DEALLOCATE(dp4tmp)
+! ------------------------------------------------------------------
+! full tables of boundary conditions
+
+ IF (nbc_data>0) THEN
+
+ out_bc(1) = out_prop(idx_hbc)
+ out_bc(2) = out_prop(idx_tbc)
+ out_bc(3) = out_prop(idx_cbc)
+
+ DO j = 1, 3
+ if (out_bc(j)) then
+ DO i = 1, 2
+ c_name = pv_name(j) // '_' // c_bt(i)
+! count the number of bc with this type (i,j)
+ k = 0
+ DO i1 = 1, nbc_data
+ IF (ibc_data(i1,cbc_pv)==j .AND. &
+ ibc_data(i1,cbc_bt)==i) k = k + 1
+ END DO
+ ALLOCATE(dp3tmp(k,ndbc,1))
+ ALLOCATE(inttmp(k,nibc,1))
+! copy the counted bc
+ k = 0
+ DO i1 = 1, nbc_data
+ IF (ibc_data(i1,cbc_pv)==j .AND. &
+ ibc_data(i1,cbc_bt)==i) THEN
+ k = k + 1
+ DO i2 = 1, nibc
+ inttmp(k,i2,1) = ibc_data(i1,i2)
+ END DO
+ DO i2 = 1, ndbc
+ dp3tmp(k,i2,1) = dbc_data(i1,i2,ismpl)
+ END DO
+ END IF
+ END DO
+
+ IF (k>0) THEN
+ dims(1) = k
+ dims(2) = nibc
+ dims(3) = 1
+ data_dims(1) = k
+ data_dims(2) = nibc
+ data_dims(3) = 1
+! for compression only
+ chunk_dims(1) = min(2000,k)
+ chunk_dims(2) = 1
+ chunk_dims(3) = 1
+ CALL h5pclose_f(plist_id,error)
+ CALL h5pcreate_f(h5p_dataset_create_f,plist_id,error)
+ CALL h5pset_chunk_f(plist_id,rank,chunk_dims,error)
+ CALL h5pset_deflate_f(plist_id,gzlevel,error)
+
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+ CALL h5dcreate_f(file_id,'i'//c_name, &
+ h5t_native_integer,dataspace,dset_id,error,plist_id)
+ CALL h5dwrite_f(dset_id,h5t_native_integer,inttmp, &
+ data_dims,error)
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+
+ dims(2) = ndbc
+ data_dims(2) = ndbc
+! for compression only
+ chunk_dims(1) = min(4000,k)
+ CALL h5pclose_f(plist_id,error)
+ CALL h5pcreate_f(h5p_dataset_create_f,plist_id,error)
+ CALL h5pset_chunk_f(plist_id,rank,chunk_dims,error)
+ CALL h5pset_deflate_f(plist_id,gzlevel,error)
+
+ CALL h5screate_simple_f(rank,dims,dataspace,error)
+ CALL h5dcreate_f(file_id,c_name,h5t_native_double, &
+ dataspace,dset_id,error,plist_id)
+ CALL h5dwrite_f(dset_id,h5t_native_double,dp3tmp, &
+ data_dims,error)
+ CALL h5sclose_f(dataspace,error)
+ CALL h5dclose_f(dset_id,error)
+ END IF
+ DEALLOCATE(inttmp)
+ DEALLOCATE(dp3tmp)
+ END DO
+ end if
+ END DO
+ END IF
+
+! ------------------------------------------------------------------
+
+! close interface
+ CALL h5pclose_f(plist_id,error)
+ CALL h5fclose_f(file_id,error)
+
+! close FORTRAN interface
+ CALL h5close_f(error)
+
+#ifdef fOMP
+!$OMP end critical
+#endif
+
+#endif
+ RETURN
+ END
diff --git a/props/bas/check_domain.f90 b/props/bas/check_domain.f90
new file mode 100644
index 0000000..4efc925
--- /dev/null
+++ b/props/bas/check_domain.f90
@@ -0,0 +1,188 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief domain of validity for module bas
+!> @param[in] ismpl local sample index
+!> @details
+!> Checking whether pres/temp/(conc) are in domain of props
+!> validity. Version for property module bas. \n
+!> \n
+!> For concentration, an error is thrown and the execution is
+!> stopped if the concentration is outside the physical values.
+ subroutine check_domain(ismpl)
+ use arrays, only: pres, temp, conc
+ use mod_genrl, only: i0, j0, k0
+ use mod_genrlc, only: def_props
+ use mod_conc, only: ntrac
+ use mod_linfos, only: linfos
+
+ implicit none
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Iteration counters
+ integer :: i, j, k, l
+
+ ! counters for the values outside domain of validity
+ ! pres
+ integer :: icountp
+ ! temp
+ integer :: icountt
+ ! conc
+ integer :: icountc
+
+ ! min/max boundaries of the domain of validity
+ ! pres
+ double precision, parameter :: pmin = 0.01d6
+ double precision, parameter :: pmax = 110.0d6
+ ! temp
+ double precision, parameter :: tmin = 0.0d0
+ double precision, parameter :: tmax = 350.0d0
+ ! conc
+ double precision, parameter :: cmin = 0.0d0
+ double precision, parameter :: cmax = 1.0d5
+ ! numerical boundary
+ double precision, parameter :: csmin = 1.0d-22
+
+ ! records the overall min/max of values if they are outside
+ ! domain of validity
+ double precision :: dpmax, dtmax, dcmax, dhmax
+ double precision :: dpmin, dtmin, dcmin, dhmin
+
+ intrinsic trim
+
+
+ ! Set counters to zero
+ icountp = 0
+ icountt = 0
+ icountc = 0
+
+ ! Set overall min/max to boundaries of the domain of validity
+ dpmax = pmax
+ dpmin = pmin
+ dtmax = tmax
+ dtmin = tmin
+ dcmax = cmax
+ dcmin = cmin
+
+ ! Check pres
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ if (pres(i,j,k,ismpl)<pmin) then
+ ! Set min counter
+ icountp = icountp + 1
+ ! Set new overall minimum
+ dpmin = min(dpmin,pres(i,j,k,ismpl))
+ ! Change pres value to minimum of the domain of validity
+ pres(i,j,k,ismpl) = pmin
+ end if
+ if (pres(i,j,k,ismpl)>pmax) then
+ ! Set max counter
+ icountp = icountp + 1
+ ! Set new overall maximum
+ dpmax = max(dpmax,pres(i,j,k,ismpl))
+ ! Change pres value to maximum of the domain of validity
+ pres(i,j,k,ismpl) = pmax
+ end if
+ end do
+ end do
+ end do
+
+ ! Check temp
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ if (temp(i,j,k,ismpl)<tmin) then
+ icountt = icountt + 1
+ dtmin = min(dtmin,temp(i,j,k,ismpl))
+ temp(i,j,k,ismpl) = tmin
+ end if
+ if (temp(i,j,k,ismpl)>tmax) then
+ icountt = icountt + 1
+ dtmax = max(dtmax,temp(i,j,k,ismpl))
+ temp(i,j,k,ismpl) = tmax
+ end if
+ end do
+ end do
+ end do
+
+ ! Check conc
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ do l = 1, ntrac
+ if (conc(i,j,k,l,ismpl).gt.cmax) then
+ icountc = icountc +1
+ dcmax = max(dcmax, conc(i,j,k,l,ismpl))
+ conc(i,j,k,l,ismpl) = cmax
+ end if
+ if (conc(i,j,k,l,ismpl)<cmin .and. &
+ conc(i,j,k,l,ismpl)<-csmin) then
+ icountc = icountc + 1
+ dcmin = min(dcmin,conc(i,j,k,l,ismpl))
+ conc(i,j,k,l,ismpl) = cmin
+ end if
+ if (conc(i,j,k,l,ismpl)<csmin) then
+ ! very small conc values set to zero to avoid
+ ! numerically instabilities
+ conc(i,j,k,l,ismpl) = cmin
+ end if
+ end do
+ end do
+ end do
+ end do
+
+! disable the warning output for linfos(3)==-1
+ if (linfos(3)>=0) then
+ if (icountp/=0) write(*,'(3A,1I8,1A,1e16.7,1A,1e16.7,1A)') &
+ 'warning: pres not in domain of validity of module <', &
+ trim(def_props), '> at ', icountp, ' points (min', dpmin, &
+ ', max', dpmax, ')!'
+ if (icountt/=0) write(*,'(3A,1I8,1A,1e16.7,1A,1e16.7,1A)') &
+ 'warning: temp not in domain of validity of module <', &
+ trim(def_props), '> at ', icountt, ' points (min', dtmin, &
+ ', max', dtmax, ')!'
+ if (icountc/=0) write(*,'(3A,1I8,1A,1e16.7,1A,1e16.7,1A)') &
+ 'warning: conc not in domain of validity of module <', &
+ trim(def_props), '> at ', icountc, ' points (min', dcmin, &
+ ', max', dcmax, ')!'
+
+ ! error outputs for hard physical concentration boundaries
+ if (dcmax > cmax) then
+ write(unit = *, fmt = *) "[E1] Error in check_domain.f90:", &
+ " maximum concentration dcmax= ", dcmax, &
+ " larger than allowed maximum value cmax=", cmax
+ stop
+ end if
+ if (dcmin > cmin) then
+ write(unit = *, fmt = *) "[E2] Error in check_domain.f90:", &
+ " minimum concentration dcmin= ", dcmin, &
+ " smaller than allowed minimum value cmin=", cmin
+ stop
+ end if
+ end if
+
+ return
+
+ end subroutine check_domain
diff --git a/props/bas/compf.f90 b/props/bas/compf.f90
new file mode 100644
index 0000000..78ec758
--- /dev/null
+++ b/props/bas/compf.f90
@@ -0,0 +1,192 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief compf calculates compressibility of pure water
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return compressibility compf [1./Pa]
+!> @details
+!> compf calculates compressibility of pure water \n
+!> given temperature (t, in C), and pressure (p,in Pa)\n
+!> at node(i,j,k).\n \n
+!>
+!> Method: \n
+!>
+!> compf = 1/rhof d/dP rhof, \n
+!>
+!> where rhof= water density.\n \n
+!>
+!> Main source of rhof (water density) approximation, see
+!> props/bas/rhof.f90. \n \n
+!>
+!> range of validity:\n
+!> - pressures 0.001 - 110 MPa,\n
+!> - temperature 15 - 360 degC\n
+ double precision function compf(i,j,k,ismpl)
+ use arrays, only: temp, pres
+ use mod_flow, only: pa_conv, pa_conv1
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Temperature (degC)
+ double precision :: tlocal
+
+ ! Pressure (MPa)
+ double precision :: plocal
+
+ ! Monomials of temperature and pressure
+ double precision :: t, t2, t3
+ double precision :: p, p2, p3, p4
+ double precision :: tp, t2p, tp2
+
+ ! Coefficients of numerator of rational function approximation
+ double precision, parameter :: Y0 = 0.10000000D+01
+ double precision, parameter :: Y1 = 0.17472599D-01
+ double precision, parameter :: Y2 = -0.20443098D-04
+ double precision, parameter :: Y3 = -0.17442012D-06
+ double precision, parameter :: Y4 = 0.49564109D-02
+ double precision, parameter :: Y5 = -0.40757664D-04
+ double precision, parameter :: Y6 = 0.50676664D-07
+ double precision, parameter :: Y7 = 0.50330978D-04
+ double precision, parameter :: Y8 = 0.33914814D-06
+ double precision, parameter :: Y9 = -0.18383009D-06
+
+ ! Coefficients of denominator of rational function approximation
+ double precision, parameter :: Z0 = 0.10009476D-02
+ double precision, parameter :: Z1 = 0.16812589D-04
+ double precision, parameter :: Z2 = -0.24582622D-07
+ double precision, parameter :: Z3 = -0.17014984D-09
+ double precision, parameter :: Z4 = 0.48841156D-05
+ double precision, parameter :: Z5 = -0.32967985D-07
+ double precision, parameter :: Z6 = 0.28619380D-10
+ double precision, parameter :: Z7 = 0.53249055D-07
+ double precision, parameter :: Z8 = 0.30456698D-09
+ double precision, parameter :: Z9 = -0.12221899D-09
+
+ ! Numerator and denominator of rational function approximation
+ double precision :: ta, tb
+
+ ! Derivative of numerator wrt P
+ double precision :: da
+
+ ! Derivative of denominator wrt P
+ double precision :: db
+
+ ! Denominator squared
+ double precision :: b2
+
+ ! Water density (local)
+ double precision :: rhof_loc
+
+ ! Derivative of water density wrt P
+ double precision :: drhodp
+
+ ! Compressibiliy in Mpa
+ double precision :: compf_mpa
+
+
+ ! Local Pressure in MPa
+ plocal = pres(i,j,k,ismpl)*pa_conv1
+
+ ! Local Temperature in degC
+ tlocal = temp(i,j,k,ismpl)
+
+ ! Temperature out of bounds
+ if (tlocal > 360.0d0) then
+ write (*,*) "[E1]: Error: Temperature (",&
+ tlocal,") out of bounds (> 360 degC) at ", i,j,k
+ stop
+ end if
+ if (tlocal < 0.0d0) then
+ ! Relax table boundary of 15degC to error boundary 0degC
+ write (*,*) "[E2]: Error: Temperature (",&
+ tlocal,") out of bounds (< 0 degC) at ", i,j,k
+ stop
+ end if
+
+ ! Pressure out of bounds
+ if (plocal > 110.0d0) then
+ write (*,*) "[E3]: Error: Pressure (",&
+ plocal,") out of bounds (> 110 MPa) at ", i,j,k
+ stop
+ end if
+ if (plocal < 0.001d0) then
+ write (*,*) "[E4]: Error: Pressure (",&
+ plocal,") out of bounds (< 0.001 MPa) at ", i,j,k
+ stop
+ end if
+
+ ! Compute monomials in pressure and temperature
+ p = plocal
+ t = tlocal
+ p2 = p*p
+ p3 = p2*p
+ p4 = p3*p
+ t2 = t*t
+ t3 = t2*t
+ tp = p*t
+ tp2 = t*p2
+ t2p = t2*p
+
+ ! Numerator of rational function approximation
+ ta = Y0 + Y1*p + Y2*p2 + Y3*p3 + Y4*t + &
+ Y5*t2 + Y6*t3 + Y7*tp + Y8*tp2 + Y9*t2p
+
+ ! Denominator of rational function approximation
+ tb = Z0 + Z1*p + Z2*p2 + Z3*p3 + Z4*t + &
+ Z5*t2 + Z6*t3 + Z7*tp + Z8*tp2 + Z9*t2p
+
+ ! Water density
+ rhof_loc = ta/tb
+
+ ! Derivative of numerator
+ da = Y1 + 2.D0*Y2*p + 3.D0*Y3*p2 + Y7*t + &
+ 2.D0*Y8*tp + Y9*t2
+
+ ! Derivative of denominator
+ db = Z1 + 2.D0*Z2*p + 3.D0*Z3*p2 + Z7*t + &
+ 2.0*Z8*tp + Z9*t2
+
+ ! Denominator squared
+ b2 = tb*tb
+
+ ! Derivative, quotient rule
+ drhodp = (da*tb-ta*db)/b2
+
+ ! Compressibility: (1/rhof_loc) * drhodp [1/MPa]
+ compf_mpa = drhodp/rhof_loc
+
+ ! Compressibility [1/Pa]
+ compf = compf_mpa / pa_conv
+
+ return
+ end function compf
diff --git a/props/bas/compm.f90 b/props/bas/compm.f90
new file mode 100644
index 0000000..977e772
--- /dev/null
+++ b/props/bas/compm.f90
@@ -0,0 +1,50 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief compm returns the compressibility of rock matrix
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return compressibility of rock [1/Pa]
+!> @details
+!> compm returns the compressibility [1/Pa] at node(i,j,k) from the
+!> input file.\n
+ double precision function compm(i,j,k,ismpl)
+ use arrays, only: propunit, uindex, idx_comp
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ compm = propunit(uindex(i,j,k),idx_comp,ismpl)
+
+ return
+
+ end function compm
diff --git a/props/bas/cpf.f90 b/props/bas/cpf.f90
new file mode 100644
index 0000000..35568f7
--- /dev/null
+++ b/props/bas/cpf.f90
@@ -0,0 +1,198 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief cpf(i,j,k,ismpl) calculates the isobaric heat capacity in (in J/kg/K)
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return cpf [J/kg/K]
+!> @details
+!> cpf(i,j,k,ismpl) calculates the isobaric heat capacity in (in
+!> J/kg/K)\n of pure water, given temperature (t, in C), and
+!> pressure (p,in Pa)\n at node(i,j,k).\n \n
+!>
+!> method: c_p = d/dT E, E= fluid enthalpy.\n \n
+!>
+!> Main source Zyvoloski1997: \n
+!>
+!> Zyvoloski, G.A., Robinson, B.A., Dash, Z.V., & Trease, L.L. Summary
+!> of the models and methods for the FEHM application - a
+!> finite-element heat- and mass-transfer code. United
+!> States. doi:10.2172/565545. \n \n
+!>
+!> Alternative source (same text, more modern, without doi): \n
+!> https://fehm.lanl.gov/orgs/ees/fehm/pdfs/fehm_mms.pdf \n \n
+!>
+!> The table of coefficients from Zyvoloski1997 describes the physical
+!> values found in Haar1984: \n
+!>
+!> Lester Haar, John Gallagher, George Kell, NBS/NRC Steam Tables:
+!> Thermodynamic and Transport Properties and Computer Programs for
+!> Vapor and Liquid States of Water in SI Units, Hemisphere Publishing
+!> Corporation, Washington, 1984. \n \n
+!>
+!> range of validity:\n
+!> pressures 0.001 - 110 MPa,\n
+!> temperature 15 - 350 degC\n
+ double precision function cpf(i,j,k,ismpl)
+ use arrays, only: pres, temp
+ use mod_flow, only: pa_conv1
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Temperature (degC)
+ double precision :: tlocal
+
+ ! Pressure (MPa)
+ double precision :: plocal
+
+ ! Enthalpy (J/kg)
+ double precision :: enth
+
+ ! Derivative of enthalpy wrt T (J/kg/K)
+ double precision :: denthdt
+
+ ! Monomials of temperature and pressure
+ double precision :: t, t2, t3
+ double precision :: p, p2, p3, p4
+ double precision :: tp, t2p, tp2
+
+ ! Coefficients of numerator of rational function approximation
+ double precision, parameter :: Y0 = 0.25623465D-3
+ double precision, parameter :: Y1 = 0.10184405D-2
+ double precision, parameter :: Y2 = 0.22554970D-4
+ double precision, parameter :: Y3 = 0.34836663D-7
+ double precision, parameter :: Y4 = 0.41769866D-2
+ double precision, parameter :: Y5 = -0.21244879D-4
+ double precision, parameter :: Y6 = 0.25493516D-7
+ double precision, parameter :: Y7 = 0.89557885D-4
+ double precision, parameter :: Y8 = 0.10855046D-6
+ double precision, parameter :: Y9 = -0.21720560D-6
+
+ ! Coefficients of denominator of rational function approximation
+ double precision, parameter :: Z0 = 0.10000000D+1
+ double precision, parameter :: Z1 = 0.23513278D-1
+ double precision, parameter :: Z2 = 0.48716386D-4
+ double precision, parameter :: Z3 = -0.19935046D-8
+ double precision, parameter :: Z4 = -0.50770309D-2
+ double precision, parameter :: Z5 = 0.57780287D-5
+ double precision, parameter :: Z6 = 0.90972916D-9
+ double precision, parameter :: Z7 = -0.58981537D-4
+ double precision, parameter :: Z8 = -0.12990752D-7
+ double precision, parameter :: Z9 = 0.45872518D-8
+
+ ! Numerator and denominator of rational function approximation
+ double precision :: ta, tb
+
+ ! Derivative of numerator wrt T
+ double precision :: da
+
+ ! Derivative of denominator wrt T
+ double precision :: db
+
+ ! Denominator squared
+ double precision :: b2
+
+
+ ! Local Pressure in MPa
+ plocal = pres(i,j,k,ismpl)*pa_conv1
+
+ ! Local Temperature in degC
+ tlocal = temp(i,j,k,ismpl)
+
+ ! Temperature out of bounds
+ if (tlocal > 360.0d0) then
+ write (*,*) "[E1]: Error: Temperature (",&
+ tlocal,") out of bounds (> 360 degC) at ", i,j,k
+ stop
+ end if
+ if (tlocal < 0.0d0) then
+ ! Relax table boundary of 15degC to error boundary 0degC
+ write (*,*) "[E2]: Error: Temperature (",&
+ tlocal,") out of bounds (< 0 degC) at ", i,j,k
+ stop
+ end if
+
+ ! Pressure out of bounds
+ if (plocal > 110.0d0) then
+ write (*,*) "[E3]: Error: Pressure (",&
+ plocal,") out of bounds (> 110 MPa) at ", i,j,k
+ stop
+ end if
+ if (plocal < 0.001d0) then
+ write (*,*) "[E4]: Error: Pressure (",&
+ plocal,") out of bounds (< 0.001 MPa) at ", i,j,k
+ stop
+ end if
+
+ ! Compute monomials in pressure and temperature
+ p = plocal
+ t = tlocal
+ p2 = p*p
+ p3 = p2*p
+ p4 = p3*p
+ t2 = t*t
+ t3 = t2*t
+ tp = p*t
+ tp2 = t*p2
+ t2p = t2*p
+
+ ! Numerator of rational function approximation
+ ta = Y0 + Y1*p + Y2*p2 + Y3*p3 + Y4*t + &
+ Y5*t2 + Y6*t3 + Y7*tp + Y8*tp2 + Y9*t2p
+
+ ! Denominator of rational function approximation
+ tb = Z0 + Z1*p + Z2*p2 + Z3*p3 + Z4*t + &
+ Z5*t2 + Z6*t3 + Z7*tp + Z8*tp2 + Z9*t2p
+
+ ! Enthalpy
+ enth = ta/tb
+
+ ! Derivative of numerator
+ da = Y4 + 2.0d0*Y5*t + 3.0d0*Y6*t2 + Y7*p + &
+ Y8*p2 + 2.0d0*Y9*tp
+
+ ! Derivative of denominator
+ db = Z4 + 2.0d0*Z5*t + 3.0d0*Z6*t2 + Z7*p + &
+ Z8*p2 + 2.0d0*Z9*tp
+
+ ! Denominator squared
+ b2 = tb*tb
+
+ ! Derivative, quotient rule
+ denthdt = da/tb - ta*db/b2
+
+ ! Isobaric heat capacity (J/kg/K)
+ cpf = denthdt*1.0d6
+
+ return
+
+ end function cpf
diff --git a/props/bas/disp.f90 b/props/bas/disp.f90
new file mode 100644
index 0000000..36737bf
--- /dev/null
+++ b/props/bas/disp.f90
@@ -0,0 +1,50 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign effective diffusivity z direction to cell
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return assign effective diffusivity
+!> @details
+!> assign effective diffusivity, called dispersivity in the input
+!> file.
+ double precision function disp(i,j,k,ismpl)
+ use arrays, only: propunit, uindex, idx_df
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ disp = propunit(uindex(i,j,k),idx_df,ismpl)
+
+ return
+
+ end function disp
diff --git a/props/bas/kx.f90 b/props/bas/kx.f90
new file mode 100644
index 0000000..fc22dae
--- /dev/null
+++ b/props/bas/kx.f90
@@ -0,0 +1,54 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign permeability in x direction to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return permeability (m^2)
+!> @details
+!> kx returns the permeability in x-direction [m2] at node(i,j,k) from
+!> the input file.\n\n
+!>
+!> The permeability in x-direction is the product of the permeability
+!> in z-direction and the anisotropy factor for the x-direction.
+ double precision function kx(i,j,k,ismpl)
+ use arrays, only: propunit, uindex, idx_kz, idx_an_kx
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ kx = propunit(uindex(i,j,k),idx_kz,ismpl)* &
+ propunit(uindex(i,j,k),idx_an_kx,ismpl)
+
+ return
+
+ end function kx
diff --git a/props/bas/ky.f90 b/props/bas/ky.f90
new file mode 100644
index 0000000..9156b5f
--- /dev/null
+++ b/props/bas/ky.f90
@@ -0,0 +1,54 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign permeability in y direction to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return permeability (m^2)
+!> @details
+!> ky returns the permeability in y-direction [m2] at node(i,j,k) from
+!> the input file.\n\n
+!>
+!> The permeability in y-direction is the product of the permeability
+!> in z-direction and the anisotropy factor for the y-direction.
+ double precision function ky(i,j,k,ismpl)
+ use arrays, only: propunit, uindex, idx_kz, idx_an_ky
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ ky = propunit(uindex(i,j,k),idx_kz,ismpl)* &
+ propunit(uindex(i,j,k),idx_an_ky,ismpl)
+
+ return
+
+ end function ky
diff --git a/props/bas/kz.f90 b/props/bas/kz.f90
new file mode 100644
index 0000000..c72f7b2
--- /dev/null
+++ b/props/bas/kz.f90
@@ -0,0 +1,50 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign permeability in z direction to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return permeability (m^2)
+!> @details
+!> kz returns the permeability in z-direction[m2] at node(i,j,k) from
+!> the input file.\n
+ double precision function kz(i,j,k,ismpl)
+ use arrays, only: propunit, uindex, idx_kz
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ kz = propunit(uindex(i,j,k),idx_kz,ismpl)
+
+ return
+
+ end function kz
diff --git a/props/bas/lamf.f90 b/props/bas/lamf.f90
new file mode 100644
index 0000000..ae283bd
--- /dev/null
+++ b/props/bas/lamf.f90
@@ -0,0 +1,84 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculate the thermal conductivity kf in W/(m*K) of water
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return thermal conductivity [W/(m*K)]
+!> @details
+!> Calculate the thermal conductivity kf in W/(m*K) of freshwater,
+!> given temperature in degC. Thermal conductivity of freshwater, kfw
+!> is calculated using the Phillips (1981) formulation (page 8). \n\n
+!>
+!> Source:\n\n
+!>
+!> Phillips, S., Igbene, A., Fair, J., Ozbek, H., & Tavana, M.,
+!> Technical databook for geothermal energy utilization (1981).
+!> http://dx.doi.org/10.2172/6301274 \n\n
+!>
+!> Range of validity: 20 to 330 degC\n\n
+!>
+!> temperature tlocal in [C]\n
+ double precision function lamf(i,j,k,ismpl)
+ use arrays, only: temp
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Temperature (degC)
+ double precision :: tlocal
+
+ ! Monomials of temperatures quotient
+ double precision :: tr, tr2, tr3, tr4
+
+ ! Coefficients of approximation
+ double precision, parameter :: c0 = -0.92247d0
+ double precision, parameter :: c1 = 2.8395d0
+ double precision, parameter :: c2 = 1.8007d0
+ double precision, parameter :: c3 = 0.52577d0
+ double precision, parameter :: c4 = 0.07344d0
+
+
+ ! Local Temperature in degC
+ tlocal = temp(i,j,k,ismpl)
+
+ ! Monomials of temperature quotient
+ tr = (tlocal+273.15d0)/273.15d0
+ tr2 = tr*tr
+ tr3 = tr2*tr
+ tr4 = tr3*tr
+
+ ! Thermal conductivity [W/(m*K)]
+ lamf = (c0 + c1*tr - c2*tr2 + c3*tr3 - c4*tr4)
+
+ return
+
+ end function lamf
diff --git a/props/bas/lamm.f90 b/props/bas/lamm.f90
new file mode 100644
index 0000000..42ede46
--- /dev/null
+++ b/props/bas/lamm.f90
@@ -0,0 +1,128 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculate temperature dependent thermal conductivity
+!> @param[in] lammref thermal conductivity from input file
+!> @param[in] tlocal temperature
+!> @param[in] tref reference temperature
+!> @param[in] ismpl local sample index
+!> @return temperature dependent thermal conductivity
+!> @details
+!> calculate temperature dependent thermal conductivity\n
+!>
+!> lam_zoth/haenel = (770degC/(350degC+T) + 0.7) W/mK
+!>
+!> If T > 800degC, use the formula from zoth & haenel, 1988. \n
+!>
+!> lamm = lam_zoth/haenel
+!>
+!> If T < 800degC, use the same formula with a factor `fct`
+!>
+!> lamm = fct * lam_zoth/haenel
+!>
+!> The factor `fct` introduces an additional temperature dependence
+!> such that\n
+!> 1. `lamm(20degC) = lammref`\n
+!> 2. `lamm(800degC) = lam_zoth/haenel(800degC)\n\n
+!>
+!> Thus, the thermal conductivity in the input file should resemble
+!> information about the value of the thermal conductivity of the
+!> matrix at temperature 20 degC.\n\n
+!>
+!> Sources: \n
+!> Zoth, G., & Haenel, R, Handbook of terrestrial heat-flow density
+!> determination, (1988), Appendix 10.1 Thermal
+!> Conductivity. http://dx.doi.org/10.1007/978-94-009-2847-3\n\n
+!>
+!> Lehmann, H., Wang, K., & Clauser, C., Parameter identification and
+!> uncertainty analysis for heat transfer at the ktb drill site using
+!> a 2-d inverse method, Tectonophysics, 291(1-4), 179–194
+!> (1998). Section 2.2 http://dx.doi.org/10.1016/s0040-1951(98)00039-0
+!> \n
+ double precision function lamm(lammref,tlocal,tref,ismpl)
+
+ implicit none
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Thermal conductivity of matrix at tref=20degC
+ double precision, intent (in) :: lammref
+
+ ! Local temperature [degC]
+ double precision, intent (in) :: tlocal
+
+ ! Reference temperature [20 degC]
+ double precision, intent (in) :: tref
+
+ ! Upper limit temperature, where the approximation becomes
+ ! equal to the general Zoth/Haenel formula
+ double precision, parameter :: tlimit = 800.0d0
+
+ ! lam_zoth/haenel at tlocal
+ double precision :: lamm_zh
+
+ ! lam_zoth/haenel at tref
+ double precision :: lamm_zhref
+
+ ! Reference Interpolation-factor
+ double precision :: fctref
+
+ ! Weight: Quotient of temperature differences
+ double precision :: twgt
+
+ ! Interpolation factor
+ double precision :: fct
+
+
+ if (tlocal > tlimit) then
+
+ ! lam_zoth/haenel at tlocal
+ lamm = 770.0d0/(350.0d0+tlocal) + 0.7D0
+
+ else
+
+ ! lam_zoth/haenel at tlocal
+ lamm_zh = 770.0d0/(350.0d0+tlocal) + 0.7d0
+
+ ! lam_zoth/haenel at tref
+ lamm_zhref = 770.0d0/(350.0d0+tref) + 0.7d0
+
+ ! Reference Interpolation-factor: Input lamm at tref divided
+ ! by lam_zoth/haenel at tref
+ fctref = lammref/lamm_zhref
+
+ ! Quotient of temperature differences, local minus reference
+ ! divided by limit minus reference
+ twgt = (tlocal-tref)/(tlimit-tref)
+
+ ! Interpolation factor between fctref at tref and 1 at tlimit
+ fct = fctref*(1-twgt) + twgt
+
+ ! Final lam: input at tref and lam_zoth/haenel at tlimit
+ lamm = fct*lamm_zh
+
+ end if
+
+ return
+
+ end function lamm
diff --git a/props/bas/lx.f90 b/props/bas/lx.f90
new file mode 100644
index 0000000..0850819
--- /dev/null
+++ b/props/bas/lx.f90
@@ -0,0 +1,98 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates effective thermal conductivity of the cell
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return thermal conductivity lx[W/(m*K)]
+!> @details
+!> calculates effective thermal conductivity of the two phase system
+!> matrix-porosity, x-direction.\n\n
+!>
+!> input:\n
+!> porosity porlocal [-]\n
+!> temperature tlocal in [degC]\n
+ double precision function lx(i,j,k,ismpl)
+ use arrays, only: temp, uindex, propunit, idx_por, idx_lz, idx_an_lx
+ use mod_temp, only: tref
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Local uindex
+ integer :: ui
+
+ ! Local temperature [degC]
+ double precision :: tlocal
+
+ ! Local porosity [-]
+ double precision :: porlocal
+
+ ! Reference matrix thermal conductivity [W/(m*K)]
+ double precision :: lammref
+
+ ! Local fluid thermal conductivity [W/(m*K)]
+ double precision :: lamfluid
+ double precision, external :: lamf
+
+ ! Local matrix thermal conductivity [W/(m*K)]
+ double precision, external :: lamm
+
+
+ ! Local Temperature in degC
+ tlocal = temp(i,j,k,ismpl)
+
+ ! Local fluid thermal conductivity [W/(m*K)]
+ lamfluid = lamf(i,j,k,ismpl)
+
+ ! Local unit index
+ ui = uindex(i,j,k)
+
+ ! Local porosity
+ porlocal = propunit(ui,idx_por,ismpl)
+
+ ! Reference matrix thermal conductivity [W/(m*K)]
+ lammref = propunit(ui,idx_lz,ismpl)*propunit(ui,idx_an_lx,ismpl)
+
+ ! Local matrix thermal conductivity [W/(m*K)]
+ lx = lamm(lammref,tlocal,tref,ismpl)
+
+ if (lx<=0.d0 .or. lamfluid<=0.d0) then
+ write(*,*) 'Error: "lx" computes bad math !', lx, lamfluid, &
+ tlocal
+ stop
+ else
+ lx = lx**(1.d0-porlocal)*lamfluid**porlocal
+ end if
+
+ return
+
+ end function lx
diff --git a/props/bas/ly.f90 b/props/bas/ly.f90
new file mode 100644
index 0000000..9490b4b
--- /dev/null
+++ b/props/bas/ly.f90
@@ -0,0 +1,98 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates effective thermal conductivity of the cell
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return thermal conductivity ly[W/(m*K)]
+!> @details
+!> calculates effective thermal conductivity of the two phase system
+!> matrix-porosity, y-direction.\n\n
+!>
+!> input:\n
+!> porosity porlocal [-]\n
+!> temperature tlocal in [degC]\n
+ double precision function ly(i,j,k,ismpl)
+ use arrays, only: temp, uindex, propunit, idx_por, idx_lz, idx_an_ly
+ use mod_temp, only: tref
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Local uindex
+ integer :: ui
+
+ ! Local temperature [degC]
+ double precision :: tlocal
+
+ ! Local porosity [-]
+ double precision :: porlocal
+
+ ! Reference matrix thermal conductivity [W/(m*K)]
+ double precision :: lammref
+
+ ! Local fluid thermal conductivity [W/(m*K)]
+ double precision :: lamfluid
+ double precision, external :: lamf
+
+ ! Local matrix thermal conductivity [W/(m*K)]
+ double precision, external :: lamm
+
+
+ ! Local Temperature in degC
+ tlocal = temp(i,j,k,ismpl)
+
+ ! Local fluid thermal conductivity [W/(m*K)]
+ lamfluid = lamf(i,j,k,ismpl)
+
+ ! Local unit index
+ ui = uindex(i,j,k)
+
+ ! Local porosity
+ porlocal = propunit(ui,idx_por,ismpl)
+
+ ! Reference matrix thermal conductivity [W/(m*K)]
+ lammref = propunit(ui,idx_lz,ismpl)*propunit(ui,idx_an_ly,ismpl)
+
+ ! Local matrix thermal conductivity [W/(m*K)]
+ ly = lamm(lammref,tlocal,tref,ismpl)
+
+ if (ly<=0.D0 .or. lamfluid<=0.D0) then
+ write(*,*) 'Error: "ly" computes bad math !', ly, lamfluid, &
+ tlocal
+ stop
+ else
+ ly = ly**(1.d0-porlocal)*lamfluid**porlocal
+ end if
+
+ return
+
+ end function ly
diff --git a/props/bas/lz.f90 b/props/bas/lz.f90
new file mode 100644
index 0000000..9aa0714
--- /dev/null
+++ b/props/bas/lz.f90
@@ -0,0 +1,98 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates effective thermal conductivity of the cell
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return thermal conductivity lz[W/(m*K)]
+!> @details
+!> calculates effective thermal conductivity of the two phase system
+!> matrix-porosity, z-direction.\n\n
+!>
+!> input:\n
+!> porosity porlocal [-]\n
+!> temperature tlocal in [degC]\n
+ double precision function lz(i,j,k,ismpl)
+ use arrays, only: temp, uindex, propunit, idx_por, idx_lz
+ use mod_temp, only: tref
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Local uindex
+ integer :: ui
+
+ ! Local temperature [degC]
+ double precision :: tlocal
+
+ ! Local porosity [-]
+ double precision :: porlocal
+
+ ! Reference matrix thermal conductivity [W/(m*K)]
+ double precision :: lammref
+
+ ! Local fluid thermal conductivity [W/(m*K)]
+ double precision :: lamfluid
+ double precision, external :: lamf
+
+ ! Local matrix thermal conductivity [W/(m*K)]
+ double precision, external :: lamm
+
+
+ ! Local Temperature in degC
+ tlocal = temp(i,j,k,ismpl)
+
+ ! Local fluid thermal conductivity [W/(m*K)]
+ lamfluid = lamf(i,j,k,ismpl)
+
+ ! Local unit index
+ ui = uindex(i,j,k)
+
+ ! Local porosity
+ porlocal = propunit(ui,idx_por,ismpl)
+
+ ! Reference matrix thermal conductivity [W/(m*K)]
+ lammref = propunit(ui,idx_lz,ismpl)
+
+ ! Local matrix thermal conductivity [W/(m*K)]
+ lz = lamm(lammref,tlocal,tref,ismpl)
+
+ if (lz<=0.d0 .or. lamfluid<=0.d0) then
+ write(*,*) 'Error: "lz" computes bad math !', lz, lamfluid, &
+ tlocal
+ stop
+ else
+ lz = lz**(1.d0-porlocal)*lamfluid**porlocal
+ end if
+
+ return
+
+ end function lz
diff --git a/props/bas/por.f90 b/props/bas/por.f90
new file mode 100644
index 0000000..d4be904
--- /dev/null
+++ b/props/bas/por.f90
@@ -0,0 +1,49 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign porosity to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return porosity porlocal [-]
+!> @details
+!> por returns the porosity [-] at node(i,j,k) from the input file.\n
+ double precision function por(i,j,k,ismpl)
+ use arrays, only: propunit, uindex, idx_por
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ por = propunit(uindex(i,j,k),idx_por,ismpl)
+
+ return
+
+ end function por
diff --git a/props/bas/props_check.f90 b/props/bas/props_check.f90
new file mode 100644
index 0000000..af007f3
--- /dev/null
+++ b/props/bas/props_check.f90
@@ -0,0 +1,63 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief check current PROPS choice
+!> @param[in] ismpl local sample index
+!> @details
+!> Check the local/current PROPS ldef_props against the PROPS choice
+!> in the input file (def_props).
+ subroutine props_check(ismpl)
+ use mod_genrlc, only: def_props
+
+ implicit none
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Local PROPS
+ character (len=10), parameter :: ldef_props = "bas"
+
+ ! Test options of command line input
+ logical, external :: test_option
+
+ intrinsic trim
+
+
+#ifndef PROPS_bas
+ write(*,'(3A)') 'error: this source was written for PROPS=', &
+ ldef_props, &
+ ', please correct this check in "props_check.f"!'
+ stop
+#endif
+ if ( .not. test_option('PROPS='//trim(def_props))) then
+ if (ldef_props/=def_props) then
+ write(*,'(7A)') 'Error: model file needs an executable', &
+ ' build from PROPS=', trim(def_props), &
+ ', but the current', ' consist of PROPS=', &
+ trim(ldef_props), '!'
+ stop
+ end if
+ end if
+
+ return
+
+ end subroutine props_check
diff --git a/props/bas/props_end.f90 b/props/bas/props_end.f90
new file mode 100644
index 0000000..fc94431
--- /dev/null
+++ b/props/bas/props_end.f90
@@ -0,0 +1,37 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief wrapper finishing property module
+!> @param[in] ismpl local sample index
+!> @details
+!> For bas: Dummy Wrapper.
+ subroutine props_end(ismpl)
+
+ implicit none
+
+ ! Sample index
+ integer :: ismpl
+
+
+ return
+
+ end subroutine props_end
diff --git a/props/bas/props_init.f90 b/props/bas/props_init.f90
new file mode 100644
index 0000000..c583244
--- /dev/null
+++ b/props/bas/props_init.f90
@@ -0,0 +1,41 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief wrapper initializing property module
+!> @param[in] ismpl local sample index
+!> @details
+!> Wrapper for calling read_props and check_props.
+ subroutine props_init(ismpl)
+
+ implicit none
+
+ ! Sample index
+ integer :: ismpl
+
+
+ CALL read_props(ismpl)
+
+ CALL check_props(ismpl)
+
+ return
+
+ end subroutine props_init
diff --git a/props/bas/qc.f90 b/props/bas/qc.f90
new file mode 100644
index 0000000..dc3b9e0
--- /dev/null
+++ b/props/bas/qc.f90
@@ -0,0 +1,55 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign transport production to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] spec species index
+!> @param[in] ismpl local sample index
+!> @return transport production
+!> @details
+!> Assign transport production to cell. \n\n
+!>
+!> Hardcoded to zero, use only if you really know that you want
+!> transport production to exist.\n
+ double precision function qc(i,j,k,spec,ismpl)
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Species index
+ integer, intent (in) :: spec
+
+ ! Sample index
+ integer :: ismpl
+
+ ! No transport production
+ qc = 0.0d0
+
+ return
+
+ end function qc
diff --git a/props/bas/qf.f90 b/props/bas/qf.f90
new file mode 100644
index 0000000..6ed3011
--- /dev/null
+++ b/props/bas/qf.f90
@@ -0,0 +1,50 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign flow production to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return flow production
+!> @details
+!> Assign flow production to cell. \n\n
+!>
+!> Hardcoded to zero, use only if you really know that you want
+!> flow production to exist.\n
+ double precision function qf(i,j,k,ismpl)
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ qf = 0.0d0
+
+ return
+
+ end function qf
diff --git a/props/bas/qt.f90 b/props/bas/qt.f90
new file mode 100644
index 0000000..284f102
--- /dev/null
+++ b/props/bas/qt.f90
@@ -0,0 +1,51 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign heat production to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return heat production
+!> @details
+!> qt returns the heat production [W/m3] at node(i,j,k) from the
+!> input file.\n
+ double precision function qt(i,j,k,ismpl)
+
+ use arrays, only: propunit, uindex, idx_q
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ qt = propunit(uindex(i,j,k),idx_q,ismpl)
+
+ return
+
+ end function qt
diff --git a/props/bas/rce.f90 b/props/bas/rce.f90
new file mode 100644
index 0000000..4811222
--- /dev/null
+++ b/props/bas/rce.f90
@@ -0,0 +1,84 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates volumetric heat capacity of the cell
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return volumetric heat capacity
+!> @details
+!> calculates volumetric heat capacity of the system
+!> matrix-porosity [J/(K*m3)].\n
+ double precision function rhoceff(i,j,k,ismpl)
+
+ use arrays, only: temp
+ ! use mod_temp
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Local temperature [degC]
+ double precision :: tlocal
+
+ ! Local porosity [-]
+ double precision :: porlocal
+ double precision, external :: por
+
+ ! Matrix fraction in cell
+ double precision :: fm
+
+ ! Fluid fraction in cell
+ double precision :: ff
+
+ ! Heat capacity of the matrix
+ double precision, external :: rhocm
+
+ ! Heat capacity of the fluid
+ double precision, external :: rhocf
+
+
+ ! Local Temperature in degC
+ tlocal = temp(i,j,k,ismpl)
+
+ ! Local porosity
+ porlocal = por(i,j,k,ismpl)
+
+ ! Matrix fraction
+ fm = 1.D0 - porlocal
+
+ ! Fluid fraction
+ ff = porlocal
+
+ ! Heat capacity in cell, arithmetic mean
+ rhoceff = ff*rhocf(i,j,k,ismpl) + fm*rhocm(i,j,k,ismpl)
+
+ return
+
+ end function rhoceff
diff --git a/props/bas/read_props.f90 b/props/bas/read_props.f90
new file mode 100644
index 0000000..e1a5af4
--- /dev/null
+++ b/props/bas/read_props.f90
@@ -0,0 +1,37 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief read additional user defined parameters
+!> @param[in] ismpl local sample index
+!> @details
+!> For bas: So far no additional user defined parameters.
+ subroutine read_props(ismpl)
+
+ implicit none
+
+ ! Sample index
+ integer :: ismpl
+
+
+ return
+
+ end subroutine read_props
diff --git a/props/bas/rhocf.f90 b/props/bas/rhocf.f90
new file mode 100644
index 0000000..ce6d69f
--- /dev/null
+++ b/props/bas/rhocf.f90
@@ -0,0 +1,62 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates heat capacity times density of water.
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return rhoc [W/(m*K)]
+!> @details
+!> calculates volumetric heat capacity of the fluid [J/(K*m3)].\n
+ double precision function rhocf(i,j,k,ismpl)
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Density of fluid [kg/m3]
+ double precision :: rfluid
+ double precision, external :: rhof
+
+ ! Water isobaric head capacity [J/(K*kg)]
+ double precision :: cfluid
+ double precision, external :: cpf
+
+ ! water density [kg/m**3]
+ rfluid = rhof(i,j,k,ismpl)
+
+ ! water isobaric heat capacity [J/(kg*K)]
+ cfluid = cpf(i,j,k,ismpl)
+
+ ! water volumetric heat capacity [J/(K*m3)]
+ rhocf = rfluid*cfluid
+
+ return
+
+ end function rhocf
diff --git a/props/bas/rhocm.f90 b/props/bas/rhocm.f90
new file mode 100644
index 0000000..68dfbb2
--- /dev/null
+++ b/props/bas/rhocm.f90
@@ -0,0 +1,62 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates heat capacity*density of rock.
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return rhoc [W/(m*K)]
+!> @details
+!> temperature tlocal in [C]\n\n
+!>
+!> Under input file "# rhocm", the temperature variation coefficients
+!> cma1, cma2, cma3 can be set. \n
+!> Default: cma1 = 1.0d0, cma2 = cma3 = 0.0d0
+ double precision function rhocm(i,j,k,ismpl)
+ use arrays, only: temp, propunit, uindex, idx_rc
+ use mod_temp, only: cma1, cma2, cma3
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Temperature (degC)
+ double precision :: tlocal
+
+
+ ! Local Temperature in degC
+ tlocal = temp(i,j,k,ismpl)
+
+ ! Volumetric heat capacity from input file [J/(kg*m3)]
+ rhocm = propunit(uindex(i,j,k),idx_rc,ismpl)* &
+ (cma1+cma2*tlocal+cma3*tlocal*tlocal)
+
+ return
+
+ end function rhocm
diff --git a/props/bas/rhof.f90 b/props/bas/rhof.f90
new file mode 100644
index 0000000..0ce5604
--- /dev/null
+++ b/props/bas/rhof.f90
@@ -0,0 +1,169 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief rhof(i,j,k,ismpl) calculates the density in (in kg/m^3) of pure water,
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return rho [kg/m^3]
+!> @details
+!> rhof(i,j,k,ismpl) calculates the density in (in kg/m^3) of pure
+!> water, given temperature (t, in degC), and pressure (p,in Pa) at
+!> node(i,j,k)\n \n
+!>
+!> Main source Zyvoloski1997: \n
+!>
+!> Zyvoloski, G.A., Robinson, B.A., Dash, Z.V., & Trease, L.L. Summary
+!> of the models and methods for the FEHM application - a
+!> finite-element heat- and mass-transfer code. United
+!> States. doi:10.2172/565545. \n \n
+!>
+!> See Section 8.4.3. of Zyvoloski1997 for an explanation of the
+!> "Rational function approximation" used in this subroutine. \n \n
+!> The approximation uses the table of coefficients in Appendix 10 of
+!> Zyvoloski1997.\n
+!>
+!> Alternative source (same text, more modern, without doi): \n
+!> https://fehm.lanl.gov/orgs/ees/fehm/pdfs/fehm_mms.pdf \n \n
+!>
+!> The table of coefficients from Zyvoloski1997 describes the physical
+!> values found in Haar1984: \n
+!>
+!> Lester Haar, John Gallagher, George Kell, NBS/NRC Steam Tables:
+!> Thermodynamic and Transport Properties and Computer Programs for
+!> Vapor and Liquid States of Water in SI Units, Hemisphere Publishing
+!> Corporation, Washington, 1984. \n \n
+!>
+!> range of validity:\n
+!> - pressures 0.001 - 110 MPa,\n
+!> - temperature 15 - 360 degC\n
+ double precision function rhof(i,j,k,ismpl)
+ use arrays, only: temp, pres
+ use mod_flow, only: pa_conv1
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Temperature (degC)
+ double precision :: tlocal
+
+ ! Pressure (MPa)
+ double precision :: plocal
+
+ ! Monomials of temperature and pressure
+ double precision :: t, t2, t3
+ double precision :: p, p2, p3, p4
+ double precision :: tp, t2p, tp2
+
+ ! Coefficients of numerator of rational function approximation
+ double precision, parameter :: Y0 = 0.10000000D+01
+ double precision, parameter :: Y1 = 0.17472599D-01
+ double precision, parameter :: Y2 = -0.20443098D-04
+ double precision, parameter :: Y3 = -0.17442012D-06
+ double precision, parameter :: Y4 = 0.49564109D-02
+ double precision, parameter :: Y5 = -0.40757664D-04
+ double precision, parameter :: Y6 = 0.50676664D-07
+ double precision, parameter :: Y7 = 0.50330978D-04
+ double precision, parameter :: Y8 = 0.33914814D-06
+ double precision, parameter :: Y9 = -0.18383009D-06
+
+ ! Coefficients of denominator of rational function approximation
+ double precision, parameter :: Z0 = 0.10009476D-02
+ double precision, parameter :: Z1 = 0.16812589D-04
+ double precision, parameter :: Z2 = -0.24582622D-07
+ double precision, parameter :: Z3 = -0.17014984D-09
+ double precision, parameter :: Z4 = 0.48841156D-05
+ double precision, parameter :: Z5 = -0.32967985D-07
+ double precision, parameter :: Z6 = 0.28619380D-10
+ double precision, parameter :: Z7 = 0.53249055D-07
+ double precision, parameter :: Z8 = 0.30456698D-09
+ double precision, parameter :: Z9 = -0.12221899D-09
+
+ ! Numerator and denominator of rational function approximation
+ double precision :: ta, tb
+
+
+ ! Local Pressure in MPa
+ plocal = pres(i,j,k,ismpl)*pa_conv1
+
+ ! Local Temperature in degC
+ tlocal = temp(i,j,k,ismpl)
+
+ ! Temperature out of bounds
+ if (tlocal > 360.0d0) then
+ write (*,*) "[E1]: Error: Temperature (",&
+ tlocal,") out of bounds (> 360 degC) at ", i,j,k
+ stop
+ end if
+ if (tlocal < 0.0d0) then
+ ! Relax table boundary of 15degC to error boundary 0degC
+ write (*,*) "[E2]: Error: Temperature (",&
+ tlocal,") out of bounds (< 0 degC) at ", i,j,k
+ stop
+ end if
+
+ ! Pressure out of bounds
+ if (plocal > 110.0d0) then
+ write (*,*) "[E3]: Error: Pressure (",&
+ plocal,") out of bounds (> 110 MPa) at ", i,j,k
+ stop
+ end if
+ if (plocal < 0.001d0) then
+ write (*,*) "[E4]: Error: Pressure (",&
+ plocal,") out of bounds (< 0.001 MPa) at ", i,j,k
+ stop
+ end if
+
+ ! Compute monomials in pressure and temperature
+ p = plocal
+ t = tlocal
+ p2 = p*p
+ p3 = p2*p
+ p4 = p3*p
+ t2 = t*t
+ t3 = t2*t
+ tp = p*t
+ tp2 = t*p2
+ t2p = t2*p
+
+ ! Numerator of rational function approximation
+ ta = Y0 + Y1*p + Y2*p2 + Y3*p3 + Y4*t + &
+ Y5*t2 + Y6*t3 + Y7*tp + Y8*tp2 + Y9*t2p
+
+ ! Denominator of rational function approximation
+ tb = Z0 + Z1*p + Z2*p2 + Z3*p3 + Z4*t + &
+ Z5*t2 + Z6*t3 + Z7*tp + Z8*tp2 + Z9*t2p
+
+ ! Water density
+ rhof = ta/tb
+
+ return
+
+ end function rhof
diff --git a/props/bas/visf.f90 b/props/bas/visf.f90
new file mode 100644
index 0000000..d88452d
--- /dev/null
+++ b/props/bas/visf.f90
@@ -0,0 +1,167 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief rhof(i,j,k,ismpl) calculates the viscosity in (in Pa s) of pure water
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return visf [Pa s]
+!> @details
+!> rhof(i,j,k,ismpl) calculates the viscosity in (in Pa s) of pure water,\n
+!> given temperature (t, in C), and pressure (p,in Pa) at node(i,j,k)\n\n
+!>
+!> Main source Zyvoloski1997: \n
+!>
+!> Zyvoloski, G.A., Robinson, B.A., Dash, Z.V., & Trease, L.L. Summary
+!> of the models and methods for the FEHM application - a
+!> finite-element heat- and mass-transfer code. United
+!> States. doi:10.2172/565545. \n \n
+!>
+!> See Section 8.4.3. of Zyvoloski1997 for an explanation of the
+!> "Rational function approximation" used in this subroutine. \n \n
+!> The approximation uses the table of coefficients in Appendix 10 of
+!> Zyvoloski1997.\n
+!>
+!> Alternative source (same text, more modern, without doi): \n
+!> https://fehm.lanl.gov/orgs/ees/fehm/pdfs/fehm_mms.pdf \n \n
+!>
+!> The table of coefficients from Zyvoloski1997 describes the physical
+!> values found in Haar1984: \n
+!>
+!> Lester Haar, John Gallagher, George Kell, NBS/NRC Steam Tables:
+!> Thermodynamic and Transport Properties and Computer Programs for
+!> Vapor and Liquid States of Water in SI Units, Hemisphere Publishing
+!> Corporation, Washington, 1984. \n \n
+!>
+!> range of validity:\n
+!> - pressures 0.001 - 110 MPa,\n
+!> - temperature 15 - 360 degC\n
+ double precision function visf(i,j,k,ismpl)
+ use arrays, only: temp, pres
+ use mod_flow, only: pa_conv1
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Temperature (degC)
+ double precision :: tlocal
+
+ ! Pressure (MPa)
+ double precision :: plocal
+
+ ! Monomials of temperature and pressure
+ double precision :: t, t2, t3
+ double precision :: p, p2, p3, p4
+ double precision :: tp, t2p, tp2
+
+ ! Coefficients of numerator of rational function approximation
+ double precision, parameter :: Y0 = 0.17409149D-02
+ double precision, parameter :: Y1 = 0.18894882D-04
+ double precision, parameter :: Y2 = -0.66439332D-07
+ double precision, parameter :: Y3 = -0.23122388D-09
+ double precision, parameter :: Y4 = -0.31534914D-05
+ double precision, parameter :: Y5 = 0.11120716D-07
+ double precision, parameter :: Y6 = -0.48576020D-10
+ double precision, parameter :: Y7 = 0.28006861D-07
+ double precision, parameter :: Y8 = 0.23225035D-09
+ double precision, parameter :: Y9 = 0.47180171D-10
+
+ ! Coefficients of denominator of rational function approximation
+ double precision, parameter :: Z0 = 0.10000000D+01
+ double precision, parameter :: Z1 = 0.10523153D-01
+ double precision, parameter :: Z2 = -0.22658391D-05
+ double precision, parameter :: Z3 = -0.31796607D-06
+ double precision, parameter :: Z4 = 0.29869141D-01
+ double precision, parameter :: Z5 = 0.21844248D-03
+ double precision, parameter :: Z6 = -0.87658855D-06
+ double precision, parameter :: Z7 = 0.41690362D-03
+ double precision, parameter :: Z8 = -0.25147022D-05
+ double precision, parameter :: Z9 = 0.22144660D-05
+
+ ! Numerator and denominator of rational function approximation
+ double precision :: ta, tb
+
+ ! Local Pressure in MPa
+ plocal = pres(i,j,k,ismpl)*pa_conv1
+
+ ! Local Temperature in degC
+ tlocal = temp(i,j,k,ismpl)
+
+ ! Temperature out of bounds
+ if (tlocal > 360.0d0) then
+ write (*,*) "[E1]: Error: Temperature (",&
+ tlocal,") out of bounds (> 360 degC) at ", i,j,k
+ stop
+ end if
+ if (tlocal < 0.0d0) then
+ ! Relax table boundary of 15degC to error boundary 0degC
+ write (*,*) "[E2]: Error: Temperature (",&
+ tlocal,") out of bounds (< 0 degC) at ", i,j,k
+ stop
+ end if
+
+ ! Pressure out of bounds
+ if (plocal > 110.0d0) then
+ write (*,*) "[E3]: Error: Pressure (",&
+ plocal,") out of bounds (> 110 MPa) at ", i,j,k
+ stop
+ end if
+ if (plocal < 0.001d0) then
+ write (*,*) "[E4]: Error: Pressure (",&
+ plocal,") out of bounds (< 0.001 MPa) at ", i,j,k
+ stop
+ end if
+
+ ! Compute monomials in pressure and temperature
+ p = plocal
+ t = tlocal
+ p2 = p*p
+ p3 = p2*p
+ p4 = p3*p
+ t2 = t*t
+ t3 = t2*t
+ tp = p*t
+ tp2 = t*p2
+ t2p = t2*p
+
+ ! Numerator of rational function approximation
+ ta = Y0 + Y1*p + Y2*p2 + Y3*p3 + Y4*t + &
+ Y5*t2 + Y6*t3 + Y7*tp + Y8*tp2 + Y9*t2p
+
+ ! Denominator of rational function approximation
+ tb = Z0 + Z1*p + Z2*p2 + Z3*p3 + Z4*t + &
+ Z5*t2 + Z6*t3 + Z7*tp + Z8*tp2 + Z9*t2p
+
+ ! Viscosity
+ visf = ta/tb
+
+ return
+
+ end function visf
diff --git a/props/basc/check_domain.f90 b/props/basc/check_domain.f90
new file mode 100644
index 0000000..b42ffba
--- /dev/null
+++ b/props/basc/check_domain.f90
@@ -0,0 +1,188 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief domain of validity for module basc
+!> @param[in] ismpl local sample index
+!> @details
+!> Checking whether pres/temp/(conc) are in domain of props
+!> validity. Version for property module basc. \n
+!> \n
+!> For concentration, an error is thrown and the execution is
+!> stopped if the concentration is outside the physical values.
+ subroutine check_domain(ismpl)
+ use arrays, only: pres, temp, conc
+ use mod_genrl, only: i0, j0, k0
+ use mod_genrlc, only: def_props
+ use mod_conc, only: ntrac
+ use mod_linfos, only: linfos
+
+ implicit none
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Iteration counters
+ integer :: i, j, k, l
+
+ ! counters for the values outside domain of validity
+ ! pres
+ integer :: icountp
+ ! temp
+ integer :: icountt
+ ! conc
+ integer :: icountc
+
+ ! min/max boundaries of the domain of validity
+ ! pres
+ double precision, parameter :: pmin = 0.01d6
+ double precision, parameter :: pmax = 110.0d6
+ ! temp
+ double precision, parameter :: tmin = 0.0d0
+ double precision, parameter :: tmax = 350.0d0
+ ! conc
+ double precision, parameter :: cmin = 0.0d0
+ double precision, parameter :: cmax = 1.0d5
+ ! numerical boundary
+ double precision, parameter :: csmin = 1.0d-30
+
+ ! records the overall min/max of values if they are outside
+ ! domain of validity
+ double precision :: dpmax, dtmax, dcmax, dhmax
+ double precision :: dpmin, dtmin, dcmin, dhmin
+
+ intrinsic trim
+
+
+ ! Set counters to zero
+ icountp = 0
+ icountt = 0
+ icountc = 0
+
+ ! Set overall min/max to boundaries of the domain of validity
+ dpmax = pmax
+ dpmin = pmin
+ dtmax = tmax
+ dtmin = tmin
+ dcmax = cmax
+ dcmin = cmin
+
+ ! Check pres
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ if (pres(i,j,k,ismpl)<pmin) then
+ ! Set min counter
+ icountp = icountp + 1
+ ! Set new overall minimum
+ dpmin = min(dpmin,pres(i,j,k,ismpl))
+ ! Change pres value to minimum of the domain of validity
+ pres(i,j,k,ismpl) = pmin
+ end if
+ if (pres(i,j,k,ismpl)>pmax) then
+ ! Set max counter
+ icountp = icountp + 1
+ ! Set new overall maximum
+ dpmax = max(dpmax,pres(i,j,k,ismpl))
+ ! Change pres value to maximum of the domain of validity
+ pres(i,j,k,ismpl) = pmax
+ end if
+ end do
+ end do
+ end do
+
+ ! Check temp
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ if (temp(i,j,k,ismpl)<tmin) then
+ icountt = icountt + 1
+ dtmin = min(dtmin,temp(i,j,k,ismpl))
+ temp(i,j,k,ismpl) = tmin
+ end if
+ if (temp(i,j,k,ismpl)>tmax) then
+ icountt = icountt + 1
+ dtmax = max(dtmax,temp(i,j,k,ismpl))
+ temp(i,j,k,ismpl) = tmax
+ end if
+ end do
+ end do
+ end do
+
+ ! Check conc
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ do l = 1, ntrac
+ if (conc(i,j,k,l,ismpl).gt.cmax) then
+ icountc = icountc +1
+ dcmax = max(dcmax, conc(i,j,k,l,ismpl))
+ conc(i,j,k,l,ismpl) = cmax
+ end if
+ if (conc(i,j,k,l,ismpl)<cmin .and. &
+ conc(i,j,k,l,ismpl)<-csmin) then
+ icountc = icountc + 1
+ dcmin = min(dcmin,conc(i,j,k,l,ismpl))
+ conc(i,j,k,l,ismpl) = cmin
+ end if
+ if (conc(i,j,k,l,ismpl)<csmin) then
+ ! very small conc values set to zero to avoid
+ ! numerically instabilities
+ conc(i,j,k,l,ismpl) = cmin
+ end if
+ end do
+ end do
+ end do
+ end do
+
+! disable the warning output for linfos(3)==-1
+ if (linfos(3)>=0) then
+ if (icountp/=0) write(*,'(3A,1I8,1A,1e16.7,1A,1e16.7,1A)') &
+ 'warning: pres not in domain of validity of module <', &
+ trim(def_props), '> at ', icountp, ' points (min', dpmin, &
+ ', max', dpmax, ')!'
+ if (icountt/=0) write(*,'(3A,1I8,1A,1e16.7,1A,1e16.7,1A)') &
+ 'warning: temp not in domain of validity of module <', &
+ trim(def_props), '> at ', icountt, ' points (min', dtmin, &
+ ', max', dtmax, ')!'
+ if (icountc/=0) write(*,'(3A,1I8,1A,1e16.7,1A,1e16.7,1A)') &
+ 'warning: conc not in domain of validity of module <', &
+ trim(def_props), '> at ', icountc, ' points (min', dcmin, &
+ ', max', dcmax, ')!'
+
+ ! error outputs for hard physical concentration boundaries
+ if (dcmax > cmax) then
+ write(unit = *, fmt = *) "[E1] Error in check_domain.f90:", &
+ " maximum concentration dcmax= ", dcmax, &
+ " larger than allowed maximum value cmax=", cmax
+ stop
+ end if
+ if (dcmin > cmin) then
+ write(unit = *, fmt = *) "[E2] Error in check_domain.f90:", &
+ " minimum concentration dcmin= ", dcmin, &
+ " smaller than allowed minimum value cmin=", cmin
+ stop
+ end if
+ end if
+
+ return
+
+ end subroutine check_domain
diff --git a/props/basc/compf.f90 b/props/basc/compf.f90
new file mode 100644
index 0000000..affec5e
--- /dev/null
+++ b/props/basc/compf.f90
@@ -0,0 +1,195 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief compf(i,j,k,ismpl) calculates the compressibility of the fluid
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return compf [1 / Pa]
+!> @details
+!> compf(i,j,k,ismpl) calculates the compressibility in (in 1/Pa) of
+!> salin water, given temperature (t, in c) pressure (p,in pa), and
+!> salinity (s, in mol/L) at node(i,j,k)\n\n
+!>
+!> Sources:\n
+!> Driesner & Heinrich, The system H2O-NaCl. Part I: Correlation
+!> formulae for phase relations in temperature-pressure-composition
+!> space from 0 to 1000 C, 0 to 5000 bar, and 0 to 1 XNaCl
+!> Geochimica et Cosmochimica Acta 71 (2007) 4880-4901\n\n
+!>
+!> Driesner, The system H2O-NaCl. Part II: Correlations for molar
+!> volume, enthalpy, and isobaric heat capacity from 0 to 1000 C, 1
+!> to 5000 bar, and 0 to 1 XNaCl Geochimica et Cosmochimica Acta 71
+!> (2007) 4902-4919\n\n
+ double precision function compf(i,j,k,ismpl)
+ use arrays, only: temp, pres, tsal
+ use mod_flow, only: pa_conv1
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Molar mass of NaCl [g/mol]
+ double precision, parameter :: mmnacl = 58.44277d0
+
+ ! Mass fraction of NaCl in solution [-]
+ double precision :: fracnacl
+
+ ! Molar mass of water, H2O [g/mol]
+ double precision, parameter :: mmwater = 18.01528d0
+
+ ! Temperature, [degC]
+ double precision :: t
+
+ ! Pressure [MPa]
+ double precision :: p
+
+ ! Monomials of pressure [bar]
+ double precision :: pb, pb2, pb3
+
+ ! Pure water compressibility [1/Pa]
+ double precision cw
+ double precision, external :: compw
+
+ ! Pure water density [kg/m3]
+ double precision rw
+ double precision, external :: rhow
+
+ ! Local salinity [mol/kg]
+ double precision :: s
+
+ ! Mole fraction of NaCl [-]
+ double precision :: xnacl
+
+ ! Temperature at which pure water has the same molar volume
+ ! as the solution [K]
+ double precision :: tv
+
+ ! Driesner2007: Coefficients
+
+ ! Equation (9)
+ double precision :: n1, n10, n11, n12
+
+ ! Equation (10)
+ double precision :: n2, n20, n21, n22, n23
+
+ ! Equation (11), (12)
+ double precision :: n1x, n2x
+
+ ! Table 4
+ double precision :: n30, n300, n301, n302
+ double precision :: n31, n310, n311, n312
+
+ ! Deviation function (13)
+ double precision :: dt
+
+
+ ! Local temperature [degC]
+ t = temp(i,j,k,ismpl)
+
+ ! Local pressure [MPa]
+ p = pres(i,j,k,ismpl)*pa_conv1
+
+ ! Local salinity [mol/L]
+ s = tsal(i,j,k,ismpl)
+
+ ! pure water compressibility [1 / Pa]
+ cw = compw(p,t)
+
+ if (s<=0.0d0) then
+
+ compf = cw
+
+ else
+ ! pure water density [g/L = kg/m3]
+ rw = rhow(p,t)
+
+ ! Pressure [bar] and pressure monomials
+ pb = p*10.0d0
+ pb2 = pb*pb
+ pb3 = pb*pb2
+
+ ! Mass fraction of NaCl, mol/L > (g/L) / (g/L) mass fraction
+ fracnacl = s*mmnacl/(rw+s*mmnacl)
+
+ ! Mole fraction of NaCl, (mol/L) / (mol/L)
+ xnacl = (fracnacl/mmnacl) / (fracnacl/mmnacl+(1-fracnacl)/mmwater)
+
+ ! Driesner2007 parameters, Table 4
+ n11 = -54.2958d0 - 45.7623d0*exp(-9.44785d-4*pb)
+ n21 = -2.6142d0 - 0.000239092d0*pb
+ n22 = 0.0356828d0 + 4.37235d-6*pb + 2.0566d-9*pb2
+ n300 = 7.60664d6 / (pb+472.051d0)**2
+ n301 = -50.0d0 - 86.1446d0*exp(-6.21128d-4*pb)
+ n302 = 294.318d0 * exp(-5.66735d-3*pb)
+ n310 = -0.0732761d0 * exp(-2.3772d-3*pb) - 5.2948d-5*pb
+ n311 = -47.2747d0 + 24.3653d0*exp(-1.25533D-3*pb)
+ n312 = -0.278529 - 0.00081381*pb
+
+ ! Driesner2007: n1 and n2 parameters for liquid NaCl
+ n1x = 330.47d0 + 0.942876d0*sqrt(pb) + 0.0817193*pb - &
+ 2.47556D-8*pb2 + 3.45052D-10*pb3
+ n2x = -0.0370751 + 0.00237723*sqrt(pb) + 5.42049D-5*pb + &
+ 5.84709D-9*pb2 - 5.99373D-13*pb3
+
+ ! Driesner2007: Set xnacl=1 in (9), => n1 = n1x
+ n10 = n1x
+
+ ! Driesner2007: Set xnacl=0 in (9) => n1 = 0.0d0
+ n12 = -n10 - n11
+
+ ! Driesner2007: Set xnacl=0 in (10) => n2 = 1.0d0
+ n20 = 1.0d0 - n21*sqrt(n22)
+
+ ! Driesner2007: Set xnacl=1 in (10) => n2 = n2x
+ n23 = n2x - n20 - n21*sqrt(1.0d0+n22)
+
+ ! Driesner2007: Equation (9)
+ n1 = n10 + n11*(1.0d0-xnacl) + n12*(1.0d0-xnacl)**2
+
+ ! Driesner2007: Equation (10)
+ n2 = n20 + n21*sqrt(xnacl+n22) + n23*xnacl
+
+ ! Driesner2007: deviation function D(T) Equations (14)-(16)
+ n30 = n300 * (exp(n301*xnacl) - 1.0d0) + n302 * xnacl
+ n31 = n310 * exp(n311*xnacl) + n312 * xnacl
+ dt = n30 * exp(n31 * t)
+
+ ! Temperature at which pure water has the same molar volume
+ ! as the solution
+ tv = n1 + n2*t+dt
+
+ ! Pure water compressibility at tv
+ compf = compw(p,tv)
+
+ end if
+
+ return
+
+ end function compf
diff --git a/props/basc/compm.f90 b/props/basc/compm.f90
new file mode 100644
index 0000000..977e772
--- /dev/null
+++ b/props/basc/compm.f90
@@ -0,0 +1,50 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief compm returns the compressibility of rock matrix
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return compressibility of rock [1/Pa]
+!> @details
+!> compm returns the compressibility [1/Pa] at node(i,j,k) from the
+!> input file.\n
+ double precision function compm(i,j,k,ismpl)
+ use arrays, only: propunit, uindex, idx_comp
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ compm = propunit(uindex(i,j,k),idx_comp,ismpl)
+
+ return
+
+ end function compm
diff --git a/props/basc/compw.f90 b/props/basc/compw.f90
new file mode 100644
index 0000000..da71bc6
--- /dev/null
+++ b/props/basc/compw.f90
@@ -0,0 +1,180 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief compw calculates compressibility of pure water
+!> @param[in] p_h pressure [MPa]
+!> @param[in] t_h temperature [degC]
+!> @return compressibility compw [1./Pa]
+!> @details
+!> compw calculates compressibility of pure water [1/Pa]
+!> given temperature (t, in C), and pressure (p,in MPa)
+!> at pressure/temperature (p_h,t).\n \n
+!>
+!> Method: \n
+!>
+!> compw = 1/rhow d/dP rhow, \n
+!>
+!> where rhow= water density.\n \n
+!>
+!> Main source Zyvoloski1997: \n
+!>
+!> Zyvoloski, G.A., Robinson, B.A., Dash, Z.V., & Trease, L.L. Summary
+!> of the models and methods for the FEHM application - a
+!> finite-element heat- and mass-transfer code. United
+!> States. doi:10.2172/565545. \n \n
+!>
+!> See Section 8.4.3. of Zyvoloski1997 for an explanation of the
+!> "Rational function approximation" used in this subroutine. \n \n
+!> The approximation uses the table of coefficients in Appendix 10 of
+!> Zyvoloski1997.\n
+!>
+!> Alternative source (same text, more modern, without doi): \n
+!> https://fehm.lanl.gov/orgs/ees/fehm/pdfs/fehm_mms.pdf \n \n
+!>
+!> The table of coefficients from Zyvoloski1997 describes the physical
+!> values found in Haar1984: \n
+!>
+!> Lester Haar, John Gallagher, George Kell, NBS/NRC Steam Tables:
+!> Thermodynamic and Transport Properties and Computer Programs for
+!> Vapor and Liquid States of Water in SI Units, Hemisphere Publishing
+!> Corporation, Washington, 1984. \n \n
+!>
+!> range of validity:\n
+!> - pressures 0.001 - 110 MPa,\n
+!> - temperature 15 - 360 degC\n \n
+!>
+!> input:\n
+!> pressure p [MPa]\n
+!> temperature t in [degC]\n
+ double precision function compw(p_h,t_h)
+ use mod_flow, only: pa_conv
+
+ implicit none
+
+ ! Input Pressure (MPa)
+ DOUBLE PRECISION p_h
+
+ ! Input temperature (degc)
+ DOUBLE PRECISION t_h
+
+ ! Monomials of temperature and pressure
+ double precision :: t, t2, t3
+ double precision :: p, p2, p3, p4
+ double precision :: tp, t2p, tp2
+
+ ! Coefficients of numerator of rational function approximation
+ double precision, parameter :: Y0 = 0.10000000D+01
+ double precision, parameter :: Y1 = 0.17472599D-01
+ double precision, parameter :: Y2 = -0.20443098D-04
+ double precision, parameter :: Y3 = -0.17442012D-06
+ double precision, parameter :: Y4 = 0.49564109D-02
+ double precision, parameter :: Y5 = -0.40757664D-04
+ double precision, parameter :: Y6 = 0.50676664D-07
+ double precision, parameter :: Y7 = 0.50330978D-04
+ double precision, parameter :: Y8 = 0.33914814D-06
+ double precision, parameter :: Y9 = -0.18383009D-06
+
+ ! Coefficients of denominator of rational function approximation
+ double precision, parameter :: Z0 = 0.10009476D-02
+ double precision, parameter :: Z1 = 0.16812589D-04
+ double precision, parameter :: Z2 = -0.24582622D-07
+ double precision, parameter :: Z3 = -0.17014984D-09
+ double precision, parameter :: Z4 = 0.48841156D-05
+ double precision, parameter :: Z5 = -0.32967985D-07
+ double precision, parameter :: Z6 = 0.28619380D-10
+ double precision, parameter :: Z7 = 0.53249055D-07
+ double precision, parameter :: Z8 = 0.30456698D-09
+ double precision, parameter :: Z9 = -0.12221899D-09
+
+ ! Numerator and denominator of rational function approximation
+ double precision :: ta, tb
+
+ ! Derivative of numerator wrt P
+ double precision :: da
+
+ ! Derivative of denominator wrt P
+ double precision :: db
+
+ ! Denominator squared
+ double precision :: b2
+
+ ! Water density (local)
+ double precision :: rhow_loc
+
+ ! Derivative of water density wrt P
+ double precision :: drhodp
+
+ ! Compressibiliy in Mpa
+ double precision :: compw_mpa
+
+
+ ! pressure [MPa]
+ p = p_h
+
+ ! temperature [degC]
+ t = t_h
+
+ ! Compute monomials in pressure and temperature
+ p2 = p*p
+ p3 = p2*p
+ p4 = p3*p
+ t2 = t*t
+ t3 = t2*t
+ tp = p*t
+ t2p = t2*p
+ tp2 = t*p2
+
+ ! Numerator of rational function approximation
+ ta = Y0 + Y1*p + Y2*p2 + Y3*p3 + Y4*t + &
+ Y5*t2 + Y6*t3 + Y7*tp + Y8*tp2 + Y9*t2p
+
+ ! Denominator of rational function approximation
+ tb = Z0 + Z1*p + Z2*p2 + Z3*p3 + Z4*t + &
+ Z5*t2 + Z6*t3 + Z7*tp + Z8*tp2 + Z9*t2p
+
+ ! Water density
+ rhow_loc = ta/tb
+
+ ! Derivative of numerator
+ da = Y1 + 2.D0*Y2*p + 3.D0*Y3*p2 + Y7*t + &
+ 2.D0*Y8*tp + Y9*t2
+
+ ! Derivative of denominator
+ db = Z1 + 2.D0*Z2*p + 3.D0*Z3*p2 + Z7*t + &
+ 2.0*Z8*tp + Z9*t2
+
+ ! Denominator squared
+ b2 = tb*tb
+
+ ! Derivative, quotient rule
+ drhodp = (da*tb-ta*db)/b2
+
+ ! Compressibility: (1/rhow_loc) * drhodp [1/MPa]
+ compw_mpa = drhodp/rhow_loc
+
+ ! Compressibility [1/Pa]
+ compw = compw_mpa / pa_conv
+
+
+ return
+
+ end function compw
diff --git a/props/basc/cpf.f90 b/props/basc/cpf.f90
new file mode 100644
index 0000000..790830b
--- /dev/null
+++ b/props/basc/cpf.f90
@@ -0,0 +1,176 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief cpf(i,j,k,ismpl) calculates the isobaric heat capacity of the fluid [J/kg/K]
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return cpf [J/kg/K]
+!> @details
+!> cpf(i,j,k,ismpl) calculates the isobaric heat capacity in (in
+!> J/kg/K) of brine, given temperature (t, in degC) pressure (p,in MPa),
+!> and salinity (s, in mol/L) at node(i,j,k)\\n \n
+!>
+!> Source:\n
+!> Driesner & Heinrich, The system H2O-NaCl. Part I: Correlation
+!> formulae for phase relations in temperature-pressure-composition
+!> space from 0 to 1000 C, 0 to 5000 bar, and 0 to 1 XNaCl
+!> Geochimica et Cosmochimica Acta 71 (2007) 4880-4901\n\n
+!>
+!> Driesner, The system H2O-NaCl. Part II: Correlations for molar
+!> volume, enthalpy, and isobaric heat capacity from 0 to 1000 C, 1
+!> to 5000 bar, and 0 to 1 XNaCl Geochimica et Cosmochimica Acta 71
+!> (2007) 4902-4919\n \n
+ double precision function cpf(i,j,k,ismpl)
+ use arrays, only: temp, pres, tsal
+ use mod_flow, only: pa_conv1
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Local Temperature, [degC]
+ double precision :: t
+
+ ! Local Pressure [MPa]
+ double precision :: p
+
+ ! Local salinity [mol/kg]
+ double precision :: s
+
+ ! Monomials of pressure [bar]
+ double precision :: pb, pb2
+
+ ! Pure water compressibility [1/Pa]
+ double precision cw
+ double precision, external :: compw
+
+ ! Pure water density [kg/m3]
+ double precision rw
+ double precision, external :: rhow
+
+ ! Pure water thermal conductivity [J/kg/K]
+ double precision, external :: cpw
+
+ ! Molar mass of NaCl [g/mol]
+ double precision, parameter :: mmnacl = 58.44277d0
+
+ ! Mass fraction of NaCl in solution [-]
+ double precision :: fracnacl
+
+ ! Molar mass of water, H2O [g/mol]
+ double precision, parameter :: mmwater = 18.01528d0
+
+ ! Mole fraction of NaCl [-]
+ double precision :: xnacl
+
+ ! Temperature at which pure water has the same specific
+ ! enthalpy as the solution [K]
+ double precision :: tv
+
+ ! Driesner2007: Coefficients
+
+ ! Equation (23)
+ double precision :: q1, q10, q11, q12
+
+ ! Equation (24)
+ double precision :: q2, q20, q21, q22, q23
+
+ ! Equation (25), (26)
+ double precision :: q1x, q2x
+
+
+ ! Local temperature [degC]
+ t = temp(i,j,k,ismpl)
+
+ ! Local pressure [MPa]
+ p = pres(i,j,k,ismpl)*pa_conv1
+
+ ! Local salinity [mol/L]
+ s = tsal(i,j,k,ismpl)
+
+ if (s<=0.0d0) then
+
+ ! Pure water heat capacity
+ cpf = cpw(p,t)
+
+ else
+
+ ! pure water density [g/L = kg/m3]
+ rw = rhow(p,t)
+
+ ! Pressure monomials [bar]
+ pb = p*10.0d0
+ pb2 = pb*pb
+
+ ! Mass fraction of NaCl, mol/L > (g/L) / (g/L) mass fraction
+ fracnacl = s*mmnacl/(rw+s*mmnacl)
+
+ ! Mole fraction of NaCl, (mol/L) / (mol/L)
+ xnacl = (fracnacl/mmnacl) / (fracnacl/mmnacl+(1-fracnacl)/mmwater)
+
+ ! Driesner2007 parameters, Table 5
+ q11 = -32.1724d0 + 0.0621255d0*pb
+ q21 = -1.69513d0 - 4.52781d-4*pb - 6.04279d-8*pb2
+ q22 = 0.0612567d0 + 1.88082d-5*pb
+
+ ! Driesner2007: q1 and q2 parameters for liquid NaCl
+ q1x = 47.9048d0 - 9.36994d-3*pb + 6.51059d-6*pb2
+ q2x = 0.241022d0 + 3.45087d-5*pb - 4.28356d-9*pb2
+
+ ! Driesner2007: Set xnacl=1 in (23) => q1 = q1x
+ q10 = q1x
+
+ ! Driesner2007: Set xnacl=0 in (23) => q1 = 0.0d0
+ q12 = -q10 - q11
+
+ ! Driesner2007: Set xnacl=0 in (24) => q2 = 1.0d0
+ q20 = 1.0d0 - q21*sqrt(q22)
+
+ ! Driesner2007: Set xnacl=1 in (10) => q2 = q2x
+ q23 = q2x - q20 - q21*sqrt(1.0d0+q22)
+
+ ! Driesner2007: Equation (23)
+ q1 = q10 + q11*(1.0d0-xnacl) + q12*(1.0d0-xnacl)**2
+
+ ! Driesner2007: Equation (24)
+ q2 = q20 + q21*sqrt(xnacl+q22) + q23*xnacl
+
+ ! Temperature at which pure water has the same specific
+ ! enthalpy as the solution
+ tv = q1 + q2*t
+
+ ! Isobaric heat capacity of solution
+ cpf = q2*cpw(p,tv)
+
+ end if
+
+ return
+
+ end function cpf
diff --git a/props/basc/cpw.f90 b/props/basc/cpw.f90
new file mode 100644
index 0000000..d15d38b
--- /dev/null
+++ b/props/basc/cpw.f90
@@ -0,0 +1,179 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief cpf(i,j,k,ismpl) calculates the isobaric heat capacity of water in (in J/kg/K)
+!> @param[in] p pressure [MPa]
+!> @param[in] t temperature [degC]
+!> @return cpf [J/kg/K]
+!> @details
+!> cpf(i,j,k,ismpl) calculates the isobaric heat capacity in (in
+!> J/kg/K)\n of pure water, given temperature (t, in C), and
+!> pressure (p,in Pa)\n at node(i,j,k).\n \n
+!>
+!> method: c_p = d/dT E, E= fluid enthalpy.\n \n
+!>
+!> Main source Zyvoloski1997: \n
+!>
+!> Zyvoloski, G.A., Robinson, B.A., Dash, Z.V., & Trease, L.L. Summary
+!> of the models and methods for the FEHM application - a
+!> finite-element heat- and mass-transfer code. United
+!> States. doi:10.2172/565545. \n \n
+!>
+!> Alternative source (same text, more modern, without doi): \n
+!> https://fehm.lanl.gov/orgs/ees/fehm/pdfs/fehm_mms.pdf \n \n
+!>
+!> The table of coefficients from Zyvoloski1997 describes the physical
+!> values found in Haar1984: \n
+!>
+!> Lester Haar, John Gallagher, George Kell, NBS/NRC Steam Tables:
+!> Thermodynamic and Transport Properties and Computer Programs for
+!> Vapor and Liquid States of Water in SI Units, Hemisphere Publishing
+!> Corporation, Washington, 1984. \n \n
+!>
+!> range of validity:\n
+!> pressures 0.001 - 110 MPa,\n
+!> temperature 15 - 350 degC\n
+ double precision function cpw(p,t)
+
+ implicit none
+
+ ! Input Pressure (MPa)
+ double precision, intent (in) :: p
+
+ ! Input Temperature (degC)
+ double precision, intent (in) :: t
+
+ ! Enthalpy (J/kg)
+ double precision :: enth
+
+ ! Derivative of enthalpy wrt T (J/kg/K)
+ double precision :: denthdt
+
+ ! Monomials of temperature and pressure
+ double precision :: t2, t3
+ double precision :: p2, p3, p4
+ double precision :: tp, t2p, tp2
+
+ ! Coefficients of numerator of rational function approximation
+ double precision, parameter :: Y0 = 0.25623465D-3
+ double precision, parameter :: Y1 = 0.10184405D-2
+ double precision, parameter :: Y2 = 0.22554970D-4
+ double precision, parameter :: Y3 = 0.34836663D-7
+ double precision, parameter :: Y4 = 0.41769866D-2
+ double precision, parameter :: Y5 = -0.21244879D-4
+ double precision, parameter :: Y6 = 0.25493516D-7
+ double precision, parameter :: Y7 = 0.89557885D-4
+ double precision, parameter :: Y8 = 0.10855046D-6
+ double precision, parameter :: Y9 = -0.21720560D-6
+
+ ! Coefficients of denominator of rational function approximation
+ double precision, parameter :: Z0 = 0.10000000D+1
+ double precision, parameter :: Z1 = 0.23513278D-1
+ double precision, parameter :: Z2 = 0.48716386D-4
+ double precision, parameter :: Z3 = -0.19935046D-8
+ double precision, parameter :: Z4 = -0.50770309D-2
+ double precision, parameter :: Z5 = 0.57780287D-5
+ double precision, parameter :: Z6 = 0.90972916D-9
+ double precision, parameter :: Z7 = -0.58981537D-4
+ double precision, parameter :: Z8 = -0.12990752D-7
+ double precision, parameter :: Z9 = 0.45872518D-8
+
+ ! Numerator and denominator of rational function approximation
+ double precision :: ta, tb
+
+ ! Derivative of numerator wrt T
+ double precision :: da
+
+ ! Derivative of denominator wrt T
+ double precision :: db
+
+ ! Denominator squared
+ double precision :: b2
+
+
+ ! Temperature out of bounds
+ if (t > 360.0d0) then
+ write (*,*) "[E1]: Error: Temperature (",&
+ t,") out of bounds (> 360 degC)."
+ stop
+ end if
+ if (t < 0.0d0) then
+ ! Relax table boundary of 15degC to error boundary 0degC
+ write (*,*) "[E2]: Error: Temperature (",&
+ t,") out of bounds (< 0 degC)."
+ stop
+ end if
+
+ ! Pressure out of bounds
+ if (p > 110.0d0) then
+ write (*,*) "[E3]: Error: Pressure (",&
+ p,") out of bounds (> 110 MPa)"
+ stop
+ end if
+ if (p < 0.001d0) then
+ write (*,*) "[E4]: Error: Pressure (",&
+ p,") out of bounds (< 0.001 MPa)"
+ stop
+ end if
+
+ ! Compute monomials in pressure and temperature
+ p2 = p*p
+ p3 = p2*p
+ p4 = p3*p
+ t2 = t*t
+ t3 = t2*t
+ tp = p*t
+ tp2 = t*p2
+ t2p = t2*p
+
+ ! Numerator of rational function approximation
+ ta = Y0 + Y1*p + Y2*p2 + Y3*p3 + Y4*t + &
+ Y5*t2 + Y6*t3 + Y7*tp + Y8*tp2 + Y9*t2p
+
+ ! Denominator of rational function approximation
+ tb = Z0 + Z1*p + Z2*p2 + Z3*p3 + Z4*t + &
+ Z5*t2 + Z6*t3 + Z7*tp + Z8*tp2 + Z9*t2p
+
+ ! Enthalpy
+ enth = ta/tb
+
+ ! Derivative of numerator
+ da = Y4 + 2.0d0*Y5*t + 3.0d0*Y6*t2 + Y7*p + &
+ Y8*p2 + 2.0d0*Y9*tp
+
+ ! Derivative of denominator
+ db = Z4 + 2.0d0*Z5*t + 3.0d0*Z6*t2 + Z7*p + &
+ Z8*p2 + 2.0d0*Z9*tp
+
+ ! Denominator squared
+ b2 = tb*tb
+
+ ! Derivative, quotient rule
+ denthdt = da/tb - ta*db/b2
+
+ ! Isobaric heat capacity (J/kg/K)
+ cpw = denthdt*1.0d6
+
+
+ return
+
+ end function cpw
diff --git a/props/basc/disp.f90 b/props/basc/disp.f90
new file mode 100644
index 0000000..36737bf
--- /dev/null
+++ b/props/basc/disp.f90
@@ -0,0 +1,50 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign effective diffusivity z direction to cell
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return assign effective diffusivity
+!> @details
+!> assign effective diffusivity, called dispersivity in the input
+!> file.
+ double precision function disp(i,j,k,ismpl)
+ use arrays, only: propunit, uindex, idx_df
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ disp = propunit(uindex(i,j,k),idx_df,ismpl)
+
+ return
+
+ end function disp
diff --git a/props/basc/kx.f90 b/props/basc/kx.f90
new file mode 100644
index 0000000..fc22dae
--- /dev/null
+++ b/props/basc/kx.f90
@@ -0,0 +1,54 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign permeability in x direction to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return permeability (m^2)
+!> @details
+!> kx returns the permeability in x-direction [m2] at node(i,j,k) from
+!> the input file.\n\n
+!>
+!> The permeability in x-direction is the product of the permeability
+!> in z-direction and the anisotropy factor for the x-direction.
+ double precision function kx(i,j,k,ismpl)
+ use arrays, only: propunit, uindex, idx_kz, idx_an_kx
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ kx = propunit(uindex(i,j,k),idx_kz,ismpl)* &
+ propunit(uindex(i,j,k),idx_an_kx,ismpl)
+
+ return
+
+ end function kx
diff --git a/props/basc/ky.f90 b/props/basc/ky.f90
new file mode 100644
index 0000000..9156b5f
--- /dev/null
+++ b/props/basc/ky.f90
@@ -0,0 +1,54 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign permeability in y direction to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return permeability (m^2)
+!> @details
+!> ky returns the permeability in y-direction [m2] at node(i,j,k) from
+!> the input file.\n\n
+!>
+!> The permeability in y-direction is the product of the permeability
+!> in z-direction and the anisotropy factor for the y-direction.
+ double precision function ky(i,j,k,ismpl)
+ use arrays, only: propunit, uindex, idx_kz, idx_an_ky
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ ky = propunit(uindex(i,j,k),idx_kz,ismpl)* &
+ propunit(uindex(i,j,k),idx_an_ky,ismpl)
+
+ return
+
+ end function ky
diff --git a/props/basc/kz.f90 b/props/basc/kz.f90
new file mode 100644
index 0000000..c72f7b2
--- /dev/null
+++ b/props/basc/kz.f90
@@ -0,0 +1,50 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign permeability in z direction to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return permeability (m^2)
+!> @details
+!> kz returns the permeability in z-direction[m2] at node(i,j,k) from
+!> the input file.\n
+ double precision function kz(i,j,k,ismpl)
+ use arrays, only: propunit, uindex, idx_kz
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ kz = propunit(uindex(i,j,k),idx_kz,ismpl)
+
+ return
+
+ end function kz
diff --git a/props/basc/lamf.f90 b/props/basc/lamf.f90
new file mode 100644
index 0000000..d22e47c
--- /dev/null
+++ b/props/basc/lamf.f90
@@ -0,0 +1,123 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculate the thermal conductivity kf of fluid [W/(m*K)]
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return thermal conductivity lamf[W/(m*K)]
+!> @details
+!> calculate the thermal conductivity kf in W/(m*K) of saline water,
+!> given temperature in degC, and salinity in mass fraction (g/g)of
+!> NaCl. Thermal conductivity of freshwater, kfw is calculated using
+!> the Phillips (1981) formulation (page8). \n \n
+!>
+!> C = S./(1 + S)*1.d2;C2=C.*C; % C=salinity in mol/kg \n\n
+!> kf = kfw.*(1.d0 - (2.3434d-3 - 7.924d-6*T + 3.924d-8*T2).*C ... \n
+!> + (1.06d-5 - 2.d-8*T - 1.2d-10*T2).*C2) \n\n
+!> Source:\n\n
+!>
+!> Phillips, S., Igbene, A., Fair, J., Ozbek, H., & Tavana, M.,
+!> Technical databook for geothermal energy utilization (1981).
+!> http://dx.doi.org/10.2172/6301274 \n\n
+!>
+!> Range of validity: 20 to 330degC and up to 4 molal NaCl\n\n
+!> input:\n
+!> pressure p [MPa]\n
+!> temperature t in [C]\n
+!> salinity s in [mol/L]\n
+ double precision function lamf(i,j,k,ismpl)
+ use arrays, only: pres, temp, tsal
+ use mod_flow, only: pa_conv1
+ IMPLICIT NONE
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Local Temperature (degC)
+ double precision :: t
+
+ ! Local Pressure (MPa)
+ double precision :: p
+
+ ! Local salinity [mol/kg / mol/L]
+ double precision :: s
+
+ ! Monomials of temperature
+ double precision :: t2, t3, t4
+
+ ! Salinity from Phillips1981 [-]
+ double precision :: sr
+
+ ! Monomial of salinity from Phillips1981 [-]
+ double precision :: sr2
+
+ ! Factor for thermal conductivity, Phillips1981 (2)
+ double precision :: lamfac
+
+ ! Pure water thermal conductivity [W/(m*K)]
+ double precision, external :: lamw
+
+
+ ! Local pressure [MPa]
+ p = pres(i,j,k,ismpl)*pa_conv1
+
+ ! Local temperature [degC]
+ t = temp(i,j,k,ismpl)
+
+ ! Local salinity [mol/L / mol/kg]
+ s = tsal(i,j,k,ismpl)
+
+ if (s<=0.0d0) then
+
+ ! Pure water conductivity
+ lamf = lamw(p,t)
+
+ else
+
+ ! Salinity according to Phillips (1981) between (2) and (3)
+ sr =5844.3d0*s/(1.0d3+58.443d0*s)
+
+ ! Monomials in salinity and temperature
+ sr2 = sr*sr
+ t2 = t*t
+ t3 = t2*t
+ t4 = t3*t
+
+ ! Factor lamf/lamw from Phillips1981, eq (2)
+ lamfac = 1.0d0 - (2.3434d-3 - 7.924d-6*t + 3.924d-8*t2) * sr + &
+ (1.06d-5 - 2.0d-8*t + 1.2d-10*t2) * sr2
+
+ ! Thermal conductivity of fluid
+ lamf = lamfac*lamw(p,t)
+
+ end if
+
+ return
+
+ end function lamf
diff --git a/props/basc/lamm.f90 b/props/basc/lamm.f90
new file mode 100644
index 0000000..42ede46
--- /dev/null
+++ b/props/basc/lamm.f90
@@ -0,0 +1,128 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculate temperature dependent thermal conductivity
+!> @param[in] lammref thermal conductivity from input file
+!> @param[in] tlocal temperature
+!> @param[in] tref reference temperature
+!> @param[in] ismpl local sample index
+!> @return temperature dependent thermal conductivity
+!> @details
+!> calculate temperature dependent thermal conductivity\n
+!>
+!> lam_zoth/haenel = (770degC/(350degC+T) + 0.7) W/mK
+!>
+!> If T > 800degC, use the formula from zoth & haenel, 1988. \n
+!>
+!> lamm = lam_zoth/haenel
+!>
+!> If T < 800degC, use the same formula with a factor `fct`
+!>
+!> lamm = fct * lam_zoth/haenel
+!>
+!> The factor `fct` introduces an additional temperature dependence
+!> such that\n
+!> 1. `lamm(20degC) = lammref`\n
+!> 2. `lamm(800degC) = lam_zoth/haenel(800degC)\n\n
+!>
+!> Thus, the thermal conductivity in the input file should resemble
+!> information about the value of the thermal conductivity of the
+!> matrix at temperature 20 degC.\n\n
+!>
+!> Sources: \n
+!> Zoth, G., & Haenel, R, Handbook of terrestrial heat-flow density
+!> determination, (1988), Appendix 10.1 Thermal
+!> Conductivity. http://dx.doi.org/10.1007/978-94-009-2847-3\n\n
+!>
+!> Lehmann, H., Wang, K., & Clauser, C., Parameter identification and
+!> uncertainty analysis for heat transfer at the ktb drill site using
+!> a 2-d inverse method, Tectonophysics, 291(1-4), 179–194
+!> (1998). Section 2.2 http://dx.doi.org/10.1016/s0040-1951(98)00039-0
+!> \n
+ double precision function lamm(lammref,tlocal,tref,ismpl)
+
+ implicit none
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Thermal conductivity of matrix at tref=20degC
+ double precision, intent (in) :: lammref
+
+ ! Local temperature [degC]
+ double precision, intent (in) :: tlocal
+
+ ! Reference temperature [20 degC]
+ double precision, intent (in) :: tref
+
+ ! Upper limit temperature, where the approximation becomes
+ ! equal to the general Zoth/Haenel formula
+ double precision, parameter :: tlimit = 800.0d0
+
+ ! lam_zoth/haenel at tlocal
+ double precision :: lamm_zh
+
+ ! lam_zoth/haenel at tref
+ double precision :: lamm_zhref
+
+ ! Reference Interpolation-factor
+ double precision :: fctref
+
+ ! Weight: Quotient of temperature differences
+ double precision :: twgt
+
+ ! Interpolation factor
+ double precision :: fct
+
+
+ if (tlocal > tlimit) then
+
+ ! lam_zoth/haenel at tlocal
+ lamm = 770.0d0/(350.0d0+tlocal) + 0.7D0
+
+ else
+
+ ! lam_zoth/haenel at tlocal
+ lamm_zh = 770.0d0/(350.0d0+tlocal) + 0.7d0
+
+ ! lam_zoth/haenel at tref
+ lamm_zhref = 770.0d0/(350.0d0+tref) + 0.7d0
+
+ ! Reference Interpolation-factor: Input lamm at tref divided
+ ! by lam_zoth/haenel at tref
+ fctref = lammref/lamm_zhref
+
+ ! Quotient of temperature differences, local minus reference
+ ! divided by limit minus reference
+ twgt = (tlocal-tref)/(tlimit-tref)
+
+ ! Interpolation factor between fctref at tref and 1 at tlimit
+ fct = fctref*(1-twgt) + twgt
+
+ ! Final lam: input at tref and lam_zoth/haenel at tlimit
+ lamm = fct*lamm_zh
+
+ end if
+
+ return
+
+ end function lamm
diff --git a/props/basc/lamw.f90 b/props/basc/lamw.f90
new file mode 100644
index 0000000..e7c96ef
--- /dev/null
+++ b/props/basc/lamw.f90
@@ -0,0 +1,77 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculate the thermal conductivity kf in W/(m*K) of water
+!> @param[in] p cell pressure [MPa]
+!> @param[in] t temperature [degC]
+!> @return thermal conductivity [W/(m*K)]
+!> @details
+!> Calculate the thermal conductivity kf in W/(m*K) of freshwater,
+!> given temperature in degC. Thermal conductivity of freshwater, kfw
+!> is calculated using the Phillips (1981) formulation (page 8). \n\n
+!>
+!> Source:\n\n
+!>
+!> Phillips, S., Igbene, A., Fair, J., Ozbek, H., & Tavana, M.,
+!> Technical databook for geothermal energy utilization (1981).
+!> http://dx.doi.org/10.2172/6301274 \n\n
+!>
+!> Range of validity: 20 to 330 degC\n\n
+!>
+!> temperature tlocal in [C]\n
+ double precision function lamw(p,t)
+ use arrays, only: temp
+
+ implicit none
+
+ ! Pressure p [MPa]
+ double precision, intent (in) :: p
+
+ ! Temperature t [degC]
+ double precision, intent (in) :: t
+
+ ! Temperature (degC)
+ double precision :: tlocal
+
+ ! Monomials of temperatures quotient
+ double precision :: tr, tr2, tr3, tr4
+
+ ! Coefficients of approximation
+ double precision, parameter :: c0 = -0.92247d0
+ double precision, parameter :: c1 = 2.8395d0
+ double precision, parameter :: c2 = 1.8007d0
+ double precision, parameter :: c3 = 0.52577d0
+ double precision, parameter :: c4 = 0.07344d0
+
+
+ ! Monomials of temperature quotient
+ tr = (t+273.15d0) / 273.15d0
+ tr2 = tr*tr
+ tr3 = tr2*tr
+ tr4 = tr3*tr
+
+ ! Thermal conductivity [W/(m*K)]
+ lamw = (c0 + c1*tr - c2*tr2 + c3*tr3 - c4*tr4)
+
+ return
+
+ end function lamw
diff --git a/props/basc/lx.f90 b/props/basc/lx.f90
new file mode 100644
index 0000000..0850819
--- /dev/null
+++ b/props/basc/lx.f90
@@ -0,0 +1,98 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates effective thermal conductivity of the cell
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return thermal conductivity lx[W/(m*K)]
+!> @details
+!> calculates effective thermal conductivity of the two phase system
+!> matrix-porosity, x-direction.\n\n
+!>
+!> input:\n
+!> porosity porlocal [-]\n
+!> temperature tlocal in [degC]\n
+ double precision function lx(i,j,k,ismpl)
+ use arrays, only: temp, uindex, propunit, idx_por, idx_lz, idx_an_lx
+ use mod_temp, only: tref
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Local uindex
+ integer :: ui
+
+ ! Local temperature [degC]
+ double precision :: tlocal
+
+ ! Local porosity [-]
+ double precision :: porlocal
+
+ ! Reference matrix thermal conductivity [W/(m*K)]
+ double precision :: lammref
+
+ ! Local fluid thermal conductivity [W/(m*K)]
+ double precision :: lamfluid
+ double precision, external :: lamf
+
+ ! Local matrix thermal conductivity [W/(m*K)]
+ double precision, external :: lamm
+
+
+ ! Local Temperature in degC
+ tlocal = temp(i,j,k,ismpl)
+
+ ! Local fluid thermal conductivity [W/(m*K)]
+ lamfluid = lamf(i,j,k,ismpl)
+
+ ! Local unit index
+ ui = uindex(i,j,k)
+
+ ! Local porosity
+ porlocal = propunit(ui,idx_por,ismpl)
+
+ ! Reference matrix thermal conductivity [W/(m*K)]
+ lammref = propunit(ui,idx_lz,ismpl)*propunit(ui,idx_an_lx,ismpl)
+
+ ! Local matrix thermal conductivity [W/(m*K)]
+ lx = lamm(lammref,tlocal,tref,ismpl)
+
+ if (lx<=0.d0 .or. lamfluid<=0.d0) then
+ write(*,*) 'Error: "lx" computes bad math !', lx, lamfluid, &
+ tlocal
+ stop
+ else
+ lx = lx**(1.d0-porlocal)*lamfluid**porlocal
+ end if
+
+ return
+
+ end function lx
diff --git a/props/basc/ly.f90 b/props/basc/ly.f90
new file mode 100644
index 0000000..9490b4b
--- /dev/null
+++ b/props/basc/ly.f90
@@ -0,0 +1,98 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates effective thermal conductivity of the cell
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return thermal conductivity ly[W/(m*K)]
+!> @details
+!> calculates effective thermal conductivity of the two phase system
+!> matrix-porosity, y-direction.\n\n
+!>
+!> input:\n
+!> porosity porlocal [-]\n
+!> temperature tlocal in [degC]\n
+ double precision function ly(i,j,k,ismpl)
+ use arrays, only: temp, uindex, propunit, idx_por, idx_lz, idx_an_ly
+ use mod_temp, only: tref
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Local uindex
+ integer :: ui
+
+ ! Local temperature [degC]
+ double precision :: tlocal
+
+ ! Local porosity [-]
+ double precision :: porlocal
+
+ ! Reference matrix thermal conductivity [W/(m*K)]
+ double precision :: lammref
+
+ ! Local fluid thermal conductivity [W/(m*K)]
+ double precision :: lamfluid
+ double precision, external :: lamf
+
+ ! Local matrix thermal conductivity [W/(m*K)]
+ double precision, external :: lamm
+
+
+ ! Local Temperature in degC
+ tlocal = temp(i,j,k,ismpl)
+
+ ! Local fluid thermal conductivity [W/(m*K)]
+ lamfluid = lamf(i,j,k,ismpl)
+
+ ! Local unit index
+ ui = uindex(i,j,k)
+
+ ! Local porosity
+ porlocal = propunit(ui,idx_por,ismpl)
+
+ ! Reference matrix thermal conductivity [W/(m*K)]
+ lammref = propunit(ui,idx_lz,ismpl)*propunit(ui,idx_an_ly,ismpl)
+
+ ! Local matrix thermal conductivity [W/(m*K)]
+ ly = lamm(lammref,tlocal,tref,ismpl)
+
+ if (ly<=0.D0 .or. lamfluid<=0.D0) then
+ write(*,*) 'Error: "ly" computes bad math !', ly, lamfluid, &
+ tlocal
+ stop
+ else
+ ly = ly**(1.d0-porlocal)*lamfluid**porlocal
+ end if
+
+ return
+
+ end function ly
diff --git a/props/basc/lz.f90 b/props/basc/lz.f90
new file mode 100644
index 0000000..9aa0714
--- /dev/null
+++ b/props/basc/lz.f90
@@ -0,0 +1,98 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates effective thermal conductivity of the cell
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return thermal conductivity lz[W/(m*K)]
+!> @details
+!> calculates effective thermal conductivity of the two phase system
+!> matrix-porosity, z-direction.\n\n
+!>
+!> input:\n
+!> porosity porlocal [-]\n
+!> temperature tlocal in [degC]\n
+ double precision function lz(i,j,k,ismpl)
+ use arrays, only: temp, uindex, propunit, idx_por, idx_lz
+ use mod_temp, only: tref
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Local uindex
+ integer :: ui
+
+ ! Local temperature [degC]
+ double precision :: tlocal
+
+ ! Local porosity [-]
+ double precision :: porlocal
+
+ ! Reference matrix thermal conductivity [W/(m*K)]
+ double precision :: lammref
+
+ ! Local fluid thermal conductivity [W/(m*K)]
+ double precision :: lamfluid
+ double precision, external :: lamf
+
+ ! Local matrix thermal conductivity [W/(m*K)]
+ double precision, external :: lamm
+
+
+ ! Local Temperature in degC
+ tlocal = temp(i,j,k,ismpl)
+
+ ! Local fluid thermal conductivity [W/(m*K)]
+ lamfluid = lamf(i,j,k,ismpl)
+
+ ! Local unit index
+ ui = uindex(i,j,k)
+
+ ! Local porosity
+ porlocal = propunit(ui,idx_por,ismpl)
+
+ ! Reference matrix thermal conductivity [W/(m*K)]
+ lammref = propunit(ui,idx_lz,ismpl)
+
+ ! Local matrix thermal conductivity [W/(m*K)]
+ lz = lamm(lammref,tlocal,tref,ismpl)
+
+ if (lz<=0.d0 .or. lamfluid<=0.d0) then
+ write(*,*) 'Error: "lz" computes bad math !', lz, lamfluid, &
+ tlocal
+ stop
+ else
+ lz = lz**(1.d0-porlocal)*lamfluid**porlocal
+ end if
+
+ return
+
+ end function lz
diff --git a/props/basc/por.f90 b/props/basc/por.f90
new file mode 100644
index 0000000..d4be904
--- /dev/null
+++ b/props/basc/por.f90
@@ -0,0 +1,49 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign porosity to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return porosity porlocal [-]
+!> @details
+!> por returns the porosity [-] at node(i,j,k) from the input file.\n
+ double precision function por(i,j,k,ismpl)
+ use arrays, only: propunit, uindex, idx_por
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ por = propunit(uindex(i,j,k),idx_por,ismpl)
+
+ return
+
+ end function por
diff --git a/props/basc/props_check.f90 b/props/basc/props_check.f90
new file mode 100644
index 0000000..846d353
--- /dev/null
+++ b/props/basc/props_check.f90
@@ -0,0 +1,63 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief check current PROPS choice
+!> @param[in] ismpl local sample index
+!> @details
+!> Check the local/current PROPS ldef_props against the PROPS choice
+!> in the input file (def_props).
+ subroutine props_check(ismpl)
+ use mod_genrlc, only: def_props
+
+ implicit none
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Local PROPS
+ character (len=10), parameter :: ldef_props = "basc"
+
+ ! Test options of command line input
+ logical, external :: test_option
+
+ intrinsic trim
+
+
+#ifndef PROPS_basc
+ write(*,'(3A)') 'error: this source was written for PROPS=', &
+ ldef_props, &
+ ', please correct this check in "props_check.f"!'
+ stop
+#endif
+ if ( .not. test_option('PROPS='//trim(def_props))) then
+ if (ldef_props/=def_props) then
+ write(*,'(7A)') 'Error: model file needs an executable', &
+ ' build from PROPS=', trim(def_props), &
+ ', but the current', ' consist of PROPS=', &
+ trim(ldef_props), '!'
+ stop
+ end if
+ end if
+
+ return
+
+ end subroutine props_check
diff --git a/props/basc/props_end.f90 b/props/basc/props_end.f90
new file mode 100644
index 0000000..fc94431
--- /dev/null
+++ b/props/basc/props_end.f90
@@ -0,0 +1,37 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief wrapper finishing property module
+!> @param[in] ismpl local sample index
+!> @details
+!> For bas: Dummy Wrapper.
+ subroutine props_end(ismpl)
+
+ implicit none
+
+ ! Sample index
+ integer :: ismpl
+
+
+ return
+
+ end subroutine props_end
diff --git a/props/basc/props_init.f90 b/props/basc/props_init.f90
new file mode 100644
index 0000000..c583244
--- /dev/null
+++ b/props/basc/props_init.f90
@@ -0,0 +1,41 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief wrapper initializing property module
+!> @param[in] ismpl local sample index
+!> @details
+!> Wrapper for calling read_props and check_props.
+ subroutine props_init(ismpl)
+
+ implicit none
+
+ ! Sample index
+ integer :: ismpl
+
+
+ CALL read_props(ismpl)
+
+ CALL check_props(ismpl)
+
+ return
+
+ end subroutine props_init
diff --git a/props/basc/qc.f90 b/props/basc/qc.f90
new file mode 100644
index 0000000..dc3b9e0
--- /dev/null
+++ b/props/basc/qc.f90
@@ -0,0 +1,55 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign transport production to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] spec species index
+!> @param[in] ismpl local sample index
+!> @return transport production
+!> @details
+!> Assign transport production to cell. \n\n
+!>
+!> Hardcoded to zero, use only if you really know that you want
+!> transport production to exist.\n
+ double precision function qc(i,j,k,spec,ismpl)
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Species index
+ integer, intent (in) :: spec
+
+ ! Sample index
+ integer :: ismpl
+
+ ! No transport production
+ qc = 0.0d0
+
+ return
+
+ end function qc
diff --git a/props/basc/qf.f90 b/props/basc/qf.f90
new file mode 100644
index 0000000..6ed3011
--- /dev/null
+++ b/props/basc/qf.f90
@@ -0,0 +1,50 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign flow production to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return flow production
+!> @details
+!> Assign flow production to cell. \n\n
+!>
+!> Hardcoded to zero, use only if you really know that you want
+!> flow production to exist.\n
+ double precision function qf(i,j,k,ismpl)
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ qf = 0.0d0
+
+ return
+
+ end function qf
diff --git a/props/basc/qt.f90 b/props/basc/qt.f90
new file mode 100644
index 0000000..284f102
--- /dev/null
+++ b/props/basc/qt.f90
@@ -0,0 +1,51 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign heat production to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return heat production
+!> @details
+!> qt returns the heat production [W/m3] at node(i,j,k) from the
+!> input file.\n
+ double precision function qt(i,j,k,ismpl)
+
+ use arrays, only: propunit, uindex, idx_q
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ qt = propunit(uindex(i,j,k),idx_q,ismpl)
+
+ return
+
+ end function qt
diff --git a/props/basc/rce.f90 b/props/basc/rce.f90
new file mode 100644
index 0000000..4811222
--- /dev/null
+++ b/props/basc/rce.f90
@@ -0,0 +1,84 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates volumetric heat capacity of the cell
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return volumetric heat capacity
+!> @details
+!> calculates volumetric heat capacity of the system
+!> matrix-porosity [J/(K*m3)].\n
+ double precision function rhoceff(i,j,k,ismpl)
+
+ use arrays, only: temp
+ ! use mod_temp
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Local temperature [degC]
+ double precision :: tlocal
+
+ ! Local porosity [-]
+ double precision :: porlocal
+ double precision, external :: por
+
+ ! Matrix fraction in cell
+ double precision :: fm
+
+ ! Fluid fraction in cell
+ double precision :: ff
+
+ ! Heat capacity of the matrix
+ double precision, external :: rhocm
+
+ ! Heat capacity of the fluid
+ double precision, external :: rhocf
+
+
+ ! Local Temperature in degC
+ tlocal = temp(i,j,k,ismpl)
+
+ ! Local porosity
+ porlocal = por(i,j,k,ismpl)
+
+ ! Matrix fraction
+ fm = 1.D0 - porlocal
+
+ ! Fluid fraction
+ ff = porlocal
+
+ ! Heat capacity in cell, arithmetic mean
+ rhoceff = ff*rhocf(i,j,k,ismpl) + fm*rhocm(i,j,k,ismpl)
+
+ return
+
+ end function rhoceff
diff --git a/props/basc/read_props.f90 b/props/basc/read_props.f90
new file mode 100644
index 0000000..e1a5af4
--- /dev/null
+++ b/props/basc/read_props.f90
@@ -0,0 +1,37 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief read additional user defined parameters
+!> @param[in] ismpl local sample index
+!> @details
+!> For bas: So far no additional user defined parameters.
+ subroutine read_props(ismpl)
+
+ implicit none
+
+ ! Sample index
+ integer :: ismpl
+
+
+ return
+
+ end subroutine read_props
diff --git a/props/basc/rhocf.f90 b/props/basc/rhocf.f90
new file mode 100644
index 0000000..ce6d69f
--- /dev/null
+++ b/props/basc/rhocf.f90
@@ -0,0 +1,62 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates heat capacity times density of water.
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return rhoc [W/(m*K)]
+!> @details
+!> calculates volumetric heat capacity of the fluid [J/(K*m3)].\n
+ double precision function rhocf(i,j,k,ismpl)
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Density of fluid [kg/m3]
+ double precision :: rfluid
+ double precision, external :: rhof
+
+ ! Water isobaric head capacity [J/(K*kg)]
+ double precision :: cfluid
+ double precision, external :: cpf
+
+ ! water density [kg/m**3]
+ rfluid = rhof(i,j,k,ismpl)
+
+ ! water isobaric heat capacity [J/(kg*K)]
+ cfluid = cpf(i,j,k,ismpl)
+
+ ! water volumetric heat capacity [J/(K*m3)]
+ rhocf = rfluid*cfluid
+
+ return
+
+ end function rhocf
diff --git a/props/basc/rhocm.f90 b/props/basc/rhocm.f90
new file mode 100644
index 0000000..68dfbb2
--- /dev/null
+++ b/props/basc/rhocm.f90
@@ -0,0 +1,62 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates heat capacity*density of rock.
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return rhoc [W/(m*K)]
+!> @details
+!> temperature tlocal in [C]\n\n
+!>
+!> Under input file "# rhocm", the temperature variation coefficients
+!> cma1, cma2, cma3 can be set. \n
+!> Default: cma1 = 1.0d0, cma2 = cma3 = 0.0d0
+ double precision function rhocm(i,j,k,ismpl)
+ use arrays, only: temp, propunit, uindex, idx_rc
+ use mod_temp, only: cma1, cma2, cma3
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Temperature (degC)
+ double precision :: tlocal
+
+
+ ! Local Temperature in degC
+ tlocal = temp(i,j,k,ismpl)
+
+ ! Volumetric heat capacity from input file [J/(kg*m3)]
+ rhocm = propunit(uindex(i,j,k),idx_rc,ismpl)* &
+ (cma1+cma2*tlocal+cma3*tlocal*tlocal)
+
+ return
+
+ end function rhocm
diff --git a/props/basc/rhof.f90 b/props/basc/rhof.f90
new file mode 100644
index 0000000..6761b3a
--- /dev/null
+++ b/props/basc/rhof.f90
@@ -0,0 +1,127 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief rhof(i,j,k,ismpl) calculates the density of the fluid (in kg/m^3),
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return rho [kg/m^3]
+!> @details
+!> rhow(i,j,k,ismpl) calculates the density in (in kg/m^3) of brine,
+!> given temperature (t, in c) pressure (p,in pa), and salinity (s, in
+!> mol/L) at node(i,j,k)\n
+!>
+!> Source:\n
+!> Batzle, M., & Wang, Z., Seismic properties of pore fluids,
+!> GEOPHYSICS, 57(11), 1396–1408 (1992).
+!> http://dx.doi.org/10.1190/1.1443207 \n\n
+!>
+!> Pressures 5-100 MPa, Temperature 20-350°C, Salinity <=320 g/L\n \n
+!>
+!> CODE VERIFICATION:\n
+!> INPUT: TEMP = 298.15K P =0.1013 MPa S = 0.25 g/g OUTPUT: RHO = 1187.35 kg/m3\n
+!> INPUT: TEMP = 393.15K P = 30 MPa S = 0.10 g/g OUTPUT: RHO = 1027.06 kg/m3\n\n
+!>
+!> ARGUMENTS NAME TYPE UNITS DESCRIPTION\n
+!> INPUT: Temp Real T C Temperature \n
+!> Real P Pa Pressure\n
+!> Real S g/g Salinity in mass fraction\n
+!> OUTPUT: LABEL RHO Real kg/m3 Density of brine \n
+ double precision function rhof(i,j,k,ismpl)
+ use arrays, only: temp, pres, tsal
+ use mod_flow, only: pa_conv1
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Temperature (degC)
+ double precision :: t
+
+ ! Pressure (MPa)
+ double precision :: p
+
+ ! Salinity (mol/L)
+ double precision :: s
+
+ ! Salinity fraction (g/L)
+ double precision :: sr
+
+ ! Molar mass of NaCl [g/mol]
+ ! double precision, parameter :: mmnacl = 58.44277d0
+ double precision, parameter :: mmnacl = 58.44d0
+
+ ! Pure water density (kg/m3)
+ double precision :: rw
+ double precision, external :: rhow
+
+ ! Pure water density (g/cm3)
+ double precision :: rw_gcm3
+
+ ! Fluid density (g/cm3)
+ double precision :: rhof_gcm3
+
+
+ ! Local Temperature (degC)
+ t = temp(i,j,k,ismpl)
+
+ ! Local Pressure [MPa]
+ p = pres(i,j,k,ismpl)*pa_conv1
+
+ ! Local salinity [mol/L]
+ s = tsal(i,j,k,ismpl)
+
+ ! Pure water density [kg/m3]
+ rw = rhow(p,t)
+
+
+ if (s<=0.0d0) then
+
+ rhof = rw
+
+ else
+
+ ! mol/L (Molarity) > g/g (Mass fraCtion)
+ sr = s*mmnacl/(rw+s*mmnacl)
+
+ ! Pure water density [g/cm3]
+ rw_gcm3 = rw / 1.0d3
+
+ ! Batzle, Equation (27b), densities in g/cm3
+ rhof_gcm3 = rw_gcm3 + sr*(0.668d0 + 0.44d0*sr &
+ + 1.0D-6*(3.0d2*p - 2.4d3*p*sr &
+ + t * (80.0d0 + 3.0d0*t - 3.3d3*sr - 13.0d0*p + 47.0d0*p*sr)))
+
+ ! Fluid density [kg/m3]
+ rhof = rhof_gcm3 * 1.0d3
+ end if
+
+ return
+
+ end function rhof
diff --git a/props/basc/rhow.f90 b/props/basc/rhow.f90
new file mode 100644
index 0000000..8a70911
--- /dev/null
+++ b/props/basc/rhow.f90
@@ -0,0 +1,105 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief rhow calculates the density of pure water [kg/m3]
+!> @param[in] p pressure [MPa]
+!> @param[in] t temperature [degC]
+!> @return rhow density of pure water [kg/m3]
+!> @details
+!> rhow(i,j,k,ismpl) calculates the density in (in kg/m^3) of pure
+!> water, given temperature (t, in degC), and pressure (p,in Pa)\n \n
+!>
+!> Source: \n
+!>
+!> Magri, F. (2005), Mechanismus und Fluiddynamik der
+!> Salzwasserzirkulation im Norddeutschen Becken: Ergebnisse
+!> thermohaliner numerischer Simulationen, Doktorarbeit,
+!> Geoforschungszentrum Potsdam \n \n
+!>
+!> Specifically: Equation (2.12) and Table 2-1
+ double precision function rhow(p,t)
+
+ implicit none
+
+ ! Local temperature (degC)
+ double precision, intent (in) :: t
+
+ ! Local pressure (MPa)
+ double precision, intent (in) :: p
+
+ ! Pressure in kPa
+ double precision :: pk
+
+ ! Monomials in pressure and temperature
+ double precision :: pk2, t2, t4, t6
+
+ ! Coefficients from Magri2005 Equation (2.12)
+ double precision a, b, c, d, e, f, g
+
+ ! Coefficients from Magri2005 Table 2-1
+ double precision, parameter :: a0 = 9.99792877961606D02
+ double precision, parameter :: a1 = 5.07605113140940D-04
+ double precision, parameter :: a2 = -5.28425478164183D-10
+ double precision, parameter :: b0 = 5.13864847162196D-02
+ double precision, parameter :: b1 = -3.61991396354483D-06
+ double precision, parameter :: b2 = 7.97204102509724D-12
+ double precision, parameter :: c0 = -7.53557031774437D-03
+ double precision, parameter :: c1 = 6.32712093275576D-08
+ double precision, parameter :: c2 = -1.66203631393248D-13
+ double precision, parameter :: d0 = 4.60380647957350D-05
+ double precision, parameter :: d1 = -5.61299059722121D-10
+ double precision, parameter :: d2 = 1.80924436489400D-15
+ double precision, parameter :: e0 = -2.26651454175013D-07
+ double precision, parameter :: e1 = 3.36874416675978D-12
+ double precision, parameter :: e2 = -1.30352149261326D-17
+ double precision, parameter :: f0 = 6.14889851856743D-10
+ double precision, parameter :: f1 = -1.06165223196756D-14
+ double precision, parameter :: f2 = 4.75014903737416D-20
+ double precision, parameter :: g0 = -7.39221950969522D-13
+ double precision, parameter :: g1 = 1.42790422913922D-17
+ double precision, parameter :: g2 = -7.13130230531541D-23
+
+
+ ! Unit [kPa] is needed after Magri(2005); the forwarded p is in [MPa]
+ pk = p*1000
+
+ ! Monomials in pressure and temperature
+ pk2 = pk*pk
+ t2 = t*t
+ t4 = t2*t2
+ t6 = t4*t2
+
+ ! Coefficients from Magri2005, Equation (2.12)
+ a = a0 + a1*pk + a2*pk2
+ b = b0 + b1*pk + b2*pk2
+ c = c0 + c1*pk + c2*pk2
+ d = d0 + d1*pk + d2*pk2
+ e = e0 + e1*pk + e2*pk2
+ f = f0 + f1*pk + f2*pk2
+ g = g0 + g1*pk + g2*pk2
+
+ ! Water density [kg/m3]
+ rhow = a + b*t + c*t2 + d*t2*t + e*t4 + f*t4*t + g*t6
+
+ return
+
+ end function rhow
diff --git a/props/basc/visf.f90 b/props/basc/visf.f90
new file mode 100644
index 0000000..5706195
--- /dev/null
+++ b/props/basc/visf.f90
@@ -0,0 +1,112 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates viscosity of aqueous NaCl solutions
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return visc
+!> @details
+!> Source:\n
+!> Batzle, M., & Wang, Z., Seismic properties of pore fluids,
+!> GEOPHYSICS, 57(11), 1396–1408 (1992).
+!> http://dx.doi.org/10.1190/1.1443207 \n\n
+!>\n
+!> Pressures 5-100 MPa, Temperature 20-350°C, Salinity <=320 g/L\n
+!>\n
+ double precision function visf(i,j,k,ismpl)
+ use arrays, only: pres, temp, tsal
+ use mod_flow, only: pa_conv1
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Temperature (degC)
+ double precision :: t
+
+ ! Pressure (MPa)
+ double precision :: p
+
+ ! Salinity (mol/L)
+ double precision :: s
+
+ ! Mass fraction [-]
+ double precision :: sr
+
+ ! Pure water density (kg/m3)
+ double precision :: rw
+ double precision, external :: rhow
+
+ ! Pure water viscosity [Pa s]
+ double precision, external :: visw
+
+ ! Molar mass of NaCl [g/mol]
+ ! double precision, parameter :: mmnacl = 58.44277d0
+ double precision, parameter :: mmnacl = 58.44d0
+
+ ! Viscosity [cP]
+ double precision :: visf_cp
+
+
+ ! Pressure [MPa]
+ p = pres(i,j,k,ismpl)*pa_conv1
+
+ ! Temperature [degC]
+ t = temp(i,j,k,ismpl)
+
+ ! Salinity [mol/L]
+ s = tsal(i,j,k,ismpl)
+
+
+ if (s <= 0.D0) then
+
+ visf = visw(p,t)
+
+ else
+
+ ! Pure water density [kg/m3]
+ rw = rhow(p,t)
+
+ ! mol/L (Molarity) > [g/L] = [kg/m3; ]g/g (mass fraction)
+ sr = s*mmnacl/(rw+s*mmnacl)
+
+ ! Viscosity formula after Batzle & Wang [cP]
+ visf_cp = 0.1d0 + 0.333d0 * sr &
+ + (1.65d0 + 91.9d0 * sr**3) * &
+ exp(-(0.42d0 * (sr**(0.8d0) - 0.17d0)**2 + 0.045d0) * t**(0.8d0))
+
+ ! Conversion of viscosity from [cP] to [Pa s]
+ visf = visf_cp * 1.0d-3
+
+ end if
+
+ return
+
+ end function visf
diff --git a/props/basc/visw.f90 b/props/basc/visw.f90
new file mode 100644
index 0000000..da0d321
--- /dev/null
+++ b/props/basc/visw.f90
@@ -0,0 +1,124 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief rhof(i,j,k,ismpl) calculates the viscosity in (in Pa s) of pure water
+!> @param[in] p cell pressure [MPa]
+!> @param[in] t temperature [degC]
+!> @return visw [Pa s]
+!> @details
+!> rhof(i,j,k,ismpl) calculates the viscosity in (in Pa s) of pure water,\n
+!> given temperature (t, in C), and pressure (p,in Pa) at node(i,j,k)\n\n
+!>
+!> Main source Zyvoloski1997: \n
+!>
+!> Zyvoloski, G.A., Robinson, B.A., Dash, Z.V., & Trease, L.L. Summary
+!> of the models and methods for the FEHM application - a
+!> finite-element heat- and mass-transfer code. United
+!> States. doi:10.2172/565545. \n \n
+!>
+!> See Section 8.4.3. of Zyvoloski1997 for an explanation of the
+!> "Rational function approximation" used in this subroutine. \n \n
+!> The approximation uses the table of coefficients in Appendix 10 of
+!> Zyvoloski1997.\n
+!>
+!> Alternative source (same text, more modern, without doi): \n
+!> https://fehm.lanl.gov/orgs/ees/fehm/pdfs/fehm_mms.pdf \n \n
+!>
+!> The table of coefficients from Zyvoloski1997 describes the physical
+!> values found in Haar1984: \n
+!>
+!> Lester Haar, John Gallagher, George Kell, NBS/NRC Steam Tables:
+!> Thermodynamic and Transport Properties and Computer Programs for
+!> Vapor and Liquid States of Water in SI Units, Hemisphere Publishing
+!> Corporation, Washington, 1984. \n \n
+!>
+!> range of validity:\n
+!> - pressures 0.001 - 110 MPa,\n
+!> - temperature 15 - 360 degC\n
+ double precision function visw(p,t)
+
+ implicit none
+
+ ! Temperature (degC)
+ double precision, intent (in) :: t
+
+ ! Pressure (MPa)
+ double precision, intent (in) :: p
+
+ ! Coefficients of numerator of rational function approximation
+ double precision, parameter :: Y0 = 0.17409149D-02
+ double precision, parameter :: Y1 = 0.18894882D-04
+ double precision, parameter :: Y2 = -0.66439332D-07
+ double precision, parameter :: Y3 = -0.23122388D-09
+ double precision, parameter :: Y4 = -0.31534914D-05
+ double precision, parameter :: Y5 = 0.11120716D-07
+ double precision, parameter :: Y6 = -0.48576020D-10
+ double precision, parameter :: Y7 = 0.28006861D-07
+ double precision, parameter :: Y8 = 0.23225035D-09
+ double precision, parameter :: Y9 = 0.47180171D-10
+
+ ! Coefficients of denominator of rational function approximation
+ double precision, parameter :: Z0 = 0.10000000D+01
+ double precision, parameter :: Z1 = 0.10523153D-01
+ double precision, parameter :: Z2 = -0.22658391D-05
+ double precision, parameter :: Z3 = -0.31796607D-06
+ double precision, parameter :: Z4 = 0.29869141D-01
+ double precision, parameter :: Z5 = 0.21844248D-03
+ double precision, parameter :: Z6 = -0.87658855D-06
+ double precision, parameter :: Z7 = 0.41690362D-03
+ double precision, parameter :: Z8 = -0.25147022D-05
+ double precision, parameter :: Z9 = 0.22144660D-05
+
+ ! Monomials of temperature and pressure
+ double precision :: t2, t3
+ double precision :: p2, p3, p4
+ double precision :: tp, t2p, tp2
+
+ ! Numerator and denominator of rational function approximation
+ double precision :: ta, tb
+
+
+ ! Compute monomials in pressure and temperature
+ p2 = p*p
+ p3 = p2*p
+ p4 = p3*p
+ t2 = t*t
+ t3 = t2*t
+ tp = p*t
+ tp2 = t*p2
+ t2p = t2*p
+
+
+ ! Numerator of rational function approximation
+ ta = Y0 + Y1*p + Y2*p2 + Y3*p3 + Y4*t + &
+ Y5*t2 + Y6*t3 + Y7*tp + Y8*tp2 + Y9*t2p
+
+ ! Denominator of rational function approximation
+ tb = Z0 + Z1*p + Z2*p2 + Z3*p3 + Z4*t + &
+ Z5*t2 + Z6*t3 + Z7*tp + Z8*tp2 + Z9*t2p
+
+ ! Viscosity
+ visw = ta/tb
+
+ return
+
+ end function visw
diff --git a/props/const/check_domain.f90 b/props/const/check_domain.f90
new file mode 100644
index 0000000..8a7fceb
--- /dev/null
+++ b/props/const/check_domain.f90
@@ -0,0 +1,188 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief domain of validity for module const
+!> @param[in] ismpl local sample index
+!> @details
+!> Checking whether pres/temp/(conc) are in domain of props
+!> validity. Version for property module const. \n
+!> \n
+!> For concentration, an error is thrown and the execution is
+!> stopped if the concentration is outside the physical values.
+ subroutine check_domain(ismpl)
+ use arrays, only: pres, temp, conc
+ use mod_genrl, only: i0, j0, k0
+ use mod_genrlc, only: def_props
+ use mod_conc, only: ntrac
+ use mod_linfos, only: linfos
+
+ implicit none
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Iteration counters
+ integer :: i, j, k, l
+
+ ! counters for the values outside domain of validity
+ ! pres
+ integer :: icountp
+ ! temp
+ integer :: icountt
+ ! conc
+ integer :: icountc
+
+ ! min/max boundaries of the domain of validity
+ ! pres
+ double precision, parameter :: pmin = 0.01d6
+ double precision, parameter :: pmax = 110.0d6
+ ! temp
+ double precision, parameter :: tmin = 0.0d0
+ double precision, parameter :: tmax = 350.0d0
+ ! conc
+ double precision, parameter :: cmin = 0.0d0
+ double precision, parameter :: cmax = 1.0d5
+ ! numerical boundary
+ double precision, parameter :: csmin = 1.0d-30
+
+ ! records the overall min/max of values if they are outside
+ ! domain of validity
+ double precision :: dpmax, dtmax, dcmax, dhmax
+ double precision :: dpmin, dtmin, dcmin, dhmin
+
+ intrinsic trim
+
+
+ ! Set counters to zero
+ icountp = 0
+ icountt = 0
+ icountc = 0
+
+ ! Set overall min/max to boundaries of the domain of validity
+ dpmax = pmax
+ dpmin = pmin
+ dtmax = tmax
+ dtmin = tmin
+ dcmax = cmax
+ dcmin = cmin
+
+ ! Check pres
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ if (pres(i,j,k,ismpl)<pmin) then
+ ! Set min counter
+ icountp = icountp + 1
+ ! Set new overall minimum
+ dpmin = min(dpmin,pres(i,j,k,ismpl))
+ ! Change pres value to minimum of the domain of validity
+ pres(i,j,k,ismpl) = pmin
+ end if
+ if (pres(i,j,k,ismpl)>pmax) then
+ ! Set max counter
+ icountp = icountp + 1
+ ! Set new overall maximum
+ dpmax = max(dpmax,pres(i,j,k,ismpl))
+ ! Change pres value to maximum of the domain of validity
+ pres(i,j,k,ismpl) = pmax
+ end if
+ end do
+ end do
+ end do
+
+ ! Check temp
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ if (temp(i,j,k,ismpl)<tmin) then
+ icountt = icountt + 1
+ dtmin = min(dtmin,temp(i,j,k,ismpl))
+ temp(i,j,k,ismpl) = tmin
+ end if
+ if (temp(i,j,k,ismpl)>tmax) then
+ icountt = icountt + 1
+ dtmax = max(dtmax,temp(i,j,k,ismpl))
+ temp(i,j,k,ismpl) = tmax
+ end if
+ end do
+ end do
+ end do
+
+ ! Check conc
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ do l = 1, ntrac
+ if (conc(i,j,k,l,ismpl).gt.cmax) then
+ icountc = icountc +1
+ dcmax = max(dcmax, conc(i,j,k,l,ismpl))
+ conc(i,j,k,l,ismpl) = cmax
+ end if
+ if (conc(i,j,k,l,ismpl)<cmin .and. &
+ conc(i,j,k,l,ismpl)<-csmin) then
+ icountc = icountc + 1
+ dcmin = min(dcmin,conc(i,j,k,l,ismpl))
+ conc(i,j,k,l,ismpl) = cmin
+ end if
+ if (conc(i,j,k,l,ismpl)<csmin) then
+ ! very small conc values set to zero to avoid
+ ! numerically instabilities
+ conc(i,j,k,l,ismpl) = cmin
+ end if
+ end do
+ end do
+ end do
+ end do
+
+! disable the warning output for linfos(3)==-1
+ if (linfos(3)>=0) then
+ if (icountp/=0) write(*,'(3A,1I8,1A,1e16.7,1A,1e16.7,1A)') &
+ 'warning: pres not in domain of validity of module <', &
+ trim(def_props), '> at ', icountp, ' points (min', dpmin, &
+ ', max', dpmax, ')!'
+ if (icountt/=0) write(*,'(3A,1I8,1A,1e16.7,1A,1e16.7,1A)') &
+ 'warning: temp not in domain of validity of module <', &
+ trim(def_props), '> at ', icountt, ' points (min', dtmin, &
+ ', max', dtmax, ')!'
+ if (icountc/=0) write(*,'(3A,1I8,1A,1e16.7,1A,1e16.7,1A)') &
+ 'warning: conc not in domain of validity of module <', &
+ trim(def_props), '> at ', icountc, ' points (min', dcmin, &
+ ', max', dcmax, ')!'
+
+ ! error outputs for hard physical concentration boundaries
+ if (dcmax > cmax) then
+ write(unit = *, fmt = *) "[E1] Error in check_domain.f90:", &
+ " maximum concentration dcmax= ", dcmax, &
+ " larger than allowed maximum value cmax=", cmax
+ stop
+ end if
+ if (dcmin > cmin) then
+ write(unit = *, fmt = *) "[E2] Error in check_domain.f90:", &
+ " minimum concentration dcmin= ", dcmin, &
+ " smaller than allowed minimum value cmin=", cmin
+ stop
+ end if
+ end if
+
+ return
+
+ end subroutine check_domain
diff --git a/props/const/compf.f90 b/props/const/compf.f90
new file mode 100644
index 0000000..aa53366
--- /dev/null
+++ b/props/const/compf.f90
@@ -0,0 +1,50 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates compressibility of the fluid
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return compf[Pa s]
+!> @details
+!> compf returns the compressibility of the fluid [1/Pa] at node(i,j,k)
+!> from the input file.\n
+ double precision function compf(i,j,k,ismpl)
+ use mod_const, only: fprops, pconst_compf
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ compf = fprops(pconst_compf)
+
+ return
+
+ end function compf
diff --git a/props/const/compm.f90 b/props/const/compm.f90
new file mode 100644
index 0000000..c5c6962
--- /dev/null
+++ b/props/const/compm.f90
@@ -0,0 +1,49 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief compm calculates compressibility of rock
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @details
+!> compm returns compressibility of rock at node(i,j,k) from the input
+!> file.\n
+ double precision function compm(i,j,k,ismpl)
+ use arrays, only: propunit, uindex, idx_comp
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ compm = propunit(uindex(i,j,k),idx_comp,ismpl)
+
+ return
+
+ end function compm
diff --git a/props/const/cpf.f90 b/props/const/cpf.f90
new file mode 100644
index 0000000..54ae96c
--- /dev/null
+++ b/props/const/cpf.f90
@@ -0,0 +1,50 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates isobaric heat capacity of the fluid
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return cpf[Pa s]
+!> @details
+!> input:\n
+!> cpf returns isobaric heat capacity of the fluid from the input file.\n
+ double precision function cpf(i,j,k,ismpl)
+ use mod_const, only: fprops, pconst_cpf
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ cpf = fprops(pconst_cpf)
+
+ return
+
+ end function cpf
diff --git a/props/const/disp.f90 b/props/const/disp.f90
new file mode 100644
index 0000000..36737bf
--- /dev/null
+++ b/props/const/disp.f90
@@ -0,0 +1,50 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign effective diffusivity z direction to cell
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return assign effective diffusivity
+!> @details
+!> assign effective diffusivity, called dispersivity in the input
+!> file.
+ double precision function disp(i,j,k,ismpl)
+ use arrays, only: propunit, uindex, idx_df
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ disp = propunit(uindex(i,j,k),idx_df,ismpl)
+
+ return
+
+ end function disp
diff --git a/props/const/kx.f90 b/props/const/kx.f90
new file mode 100644
index 0000000..fc22dae
--- /dev/null
+++ b/props/const/kx.f90
@@ -0,0 +1,54 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign permeability in x direction to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return permeability (m^2)
+!> @details
+!> kx returns the permeability in x-direction [m2] at node(i,j,k) from
+!> the input file.\n\n
+!>
+!> The permeability in x-direction is the product of the permeability
+!> in z-direction and the anisotropy factor for the x-direction.
+ double precision function kx(i,j,k,ismpl)
+ use arrays, only: propunit, uindex, idx_kz, idx_an_kx
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ kx = propunit(uindex(i,j,k),idx_kz,ismpl)* &
+ propunit(uindex(i,j,k),idx_an_kx,ismpl)
+
+ return
+
+ end function kx
diff --git a/props/const/ky.f90 b/props/const/ky.f90
new file mode 100644
index 0000000..9156b5f
--- /dev/null
+++ b/props/const/ky.f90
@@ -0,0 +1,54 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign permeability in y direction to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return permeability (m^2)
+!> @details
+!> ky returns the permeability in y-direction [m2] at node(i,j,k) from
+!> the input file.\n\n
+!>
+!> The permeability in y-direction is the product of the permeability
+!> in z-direction and the anisotropy factor for the y-direction.
+ double precision function ky(i,j,k,ismpl)
+ use arrays, only: propunit, uindex, idx_kz, idx_an_ky
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ ky = propunit(uindex(i,j,k),idx_kz,ismpl)* &
+ propunit(uindex(i,j,k),idx_an_ky,ismpl)
+
+ return
+
+ end function ky
diff --git a/props/const/kz.f90 b/props/const/kz.f90
new file mode 100644
index 0000000..c72f7b2
--- /dev/null
+++ b/props/const/kz.f90
@@ -0,0 +1,50 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign permeability in z direction to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return permeability (m^2)
+!> @details
+!> kz returns the permeability in z-direction[m2] at node(i,j,k) from
+!> the input file.\n
+ double precision function kz(i,j,k,ismpl)
+ use arrays, only: propunit, uindex, idx_kz
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ kz = propunit(uindex(i,j,k),idx_kz,ismpl)
+
+ return
+
+ end function kz
diff --git a/props/const/lamf.f90 b/props/const/lamf.f90
new file mode 100644
index 0000000..92f3270
--- /dev/null
+++ b/props/const/lamf.f90
@@ -0,0 +1,49 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief returns thermal conductivity of the fluid.
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return thermal conductivity lamf[W/(m*K)]
+!> @details
+!> lamf returns the thermal conductivity of the fluid [W/(m*K)] at
+!> node(i,j,k) from the input file.\n
+ double precision function lamf(i,j,k,ismpl)
+ use mod_const, only: fprops, pconst_lamf
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ lamf = fprops(pconst_lamf)
+
+ return
+
+ end function lamf
diff --git a/props/const/lx.f90 b/props/const/lx.f90
new file mode 100644
index 0000000..417668d
--- /dev/null
+++ b/props/const/lx.f90
@@ -0,0 +1,72 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates effective thermal conductivity of the cell
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return thermal conductivity lx[W/(m*K)]
+!> @details
+!> calculates effective thermal conductivity of the two phase system
+!> matrix-porosity .\n\n
+!>
+!> input:\n
+!> porosity porlocal [-]\n
+!> thermal conductivity of fluid lamf [W/(m*K)]\n
+!> thermal conductivity of matrix lammref [W/(m*K)]\n
+ double precision function lx(i,j,k,ismpl)
+ use arrays, only: propunit, uindex, idx_lz, idx_an_lx
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Local fluid thermal conductivity [W/(m*K)]
+ double precision :: lamfluid
+ double precision, external :: lamf
+
+ ! Matrix thermal conductivity [W/(m*K)]
+ double precision :: lammref
+
+ ! Local porosity [-]
+ double precision, external :: por
+
+
+ ! Local fluid thermal conductivity [W/(m*K)]
+ lamfluid = lamf(i,j,k,ismpl)
+
+ ! Reference matrix thermal conductivity [W/(m*K)]
+ lammref = propunit(uindex(i,j,k),idx_lz,ismpl)* &
+ propunit(uindex(i,j,k),idx_an_lx,ismpl)
+
+ lx = lammref**(1.0d0-por(i,j,k,ismpl))*lamfluid**por(i,j,k,ismpl)
+
+ return
+
+ end function lx
diff --git a/props/const/ly.f90 b/props/const/ly.f90
new file mode 100644
index 0000000..b293f7b
--- /dev/null
+++ b/props/const/ly.f90
@@ -0,0 +1,72 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates effective thermal conductivity of the cell
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return thermal conductivity ly[W/(m*K)]
+!> @details
+!> calculates effective thermal conductivity of the two phase system
+!> matrix-porosity .\n\n
+!>
+!> input:\n
+!> porosity porlocal [-]\n
+!> thermal conductivity of fluid lamf [W/(m*K)]\n
+!> thermal conductivity of matrix lammref [W/(m*K)]\n
+ double precision function ly(i,j,k,ismpl)
+ use arrays, only: propunit, uindex, idx_lz, idx_an_ly
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Local fluid thermal conductivity [W/(m*K)]
+ double precision :: lamfluid
+ double precision, external :: lamf
+
+ ! Matrix thermal conductivity [W/(m*K)]
+ double precision :: lammref
+
+ ! Local porosity [-]
+ double precision, external :: por
+
+
+ ! Local fluid thermal conductivity [W/(m*K)]
+ lamfluid = lamf(i,j,k,ismpl)
+
+ ! Reference matrix thermal conductivity [W/(m*K)]
+ lammref = propunit(uindex(i,j,k),idx_lz,ismpl)* &
+ propunit(uindex(i,j,k),idx_an_ly,ismpl)
+
+ ly = lammref**(1.0d0-por(i,j,k,ismpl))*lamfluid**por(i,j,k,ismpl)
+
+ return
+
+ end function ly
diff --git a/props/const/lz.f90 b/props/const/lz.f90
new file mode 100644
index 0000000..128b614
--- /dev/null
+++ b/props/const/lz.f90
@@ -0,0 +1,71 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates effective thermal conductivity of the cell
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return thermal conductivity lz[W/(m*K)]
+!> @details
+!> calculates effective thermal conductivity of the two phase system
+!> matrix-porosity .\n\n
+!>
+!> input:\n
+!> porosity porlocal [-]\n
+!> thermal conductivity of fluid lamf [W/(m*K)]\n
+!> thermal conductivity of matrix lammref [W/(m*K)]\n
+ double precision function lz(i,j,k,ismpl)
+ use arrays, only: propunit, uindex, idx_lz
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Local fluid thermal conductivity [W/(m*K)]
+ double precision :: lamfluid
+ double precision, external :: lamf
+
+ ! Matrix thermal conductivity [W/(m*K)]
+ double precision :: lammref
+
+ ! Local porosity [-]
+ double precision, external :: por
+
+
+ ! Local fluid thermal conductivity [W/(m*K)]
+ lamfluid = lamf(i,j,k,ismpl)
+
+ ! Reference matrix thermal conductivity [W/(m*K)]
+ lammref = propunit(uindex(i,j,k),idx_lz,ismpl)
+
+ lz = lammref**(1.0d0-por(i,j,k,ismpl))*lamfluid**por(i,j,k,ismpl)
+
+ return
+
+ end function lz
diff --git a/props/const/mod_const.f90 b/props/const/mod_const.f90
new file mode 100644
index 0000000..00b339c
--- /dev/null
+++ b/props/const/mod_const.f90
@@ -0,0 +1,64 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief global variables and constants for PROPS=const.
+module mod_const
+
+ !> @brief Dimension of fluid property index array.
+ !> @details
+ !> Dimension of fluid property index array. \n
+ !> Dimension of fluid property index array fprops.
+ integer, parameter :: npropsf = 5
+
+ !> @brief Index of rhof in fluid property index array.
+ !> @details
+ !> Index of rhof in fluid property index array. \n
+ integer, parameter :: pconst_rhof = 1
+
+ !> @brief Index of compf in fluid property index array.
+ !> @details
+ !> Index of compf in fluid property index array. \n
+ integer, parameter :: pconst_compf = 2
+
+ !> @brief Index of cpf in fluid property index array.
+ !> @details
+ !> Index of cpf in fluid property index array. \n
+ integer, parameter :: pconst_cpf = 3
+
+ !> @brief Index of lamf in fluid property index array.
+ !> @details
+ !> Index of lamf in fluid property index array. \n
+ integer, parameter :: pconst_lamf = 4
+
+ !> @brief Index of visf in fluid property index array.
+ !> @details
+ !> Index of visf in fluid property index array. \n
+ integer, parameter :: pconst_visf = 5
+
+ !> @brief Fluid property index array.
+ !> @details
+ !> Fluid property index array. \n
+ !> The array contains indices for parameters rhof, compf, cpf, lamf,
+ !> visf.
+ double precision, dimension (npropsf) :: fprops
+
+end module mod_const
diff --git a/props/const/por.f90 b/props/const/por.f90
new file mode 100644
index 0000000..d4be904
--- /dev/null
+++ b/props/const/por.f90
@@ -0,0 +1,49 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign porosity to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return porosity porlocal [-]
+!> @details
+!> por returns the porosity [-] at node(i,j,k) from the input file.\n
+ double precision function por(i,j,k,ismpl)
+ use arrays, only: propunit, uindex, idx_por
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ por = propunit(uindex(i,j,k),idx_por,ismpl)
+
+ return
+
+ end function por
diff --git a/props/const/props_check.f90 b/props/const/props_check.f90
new file mode 100644
index 0000000..12553ad
--- /dev/null
+++ b/props/const/props_check.f90
@@ -0,0 +1,63 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief check current PROPS choice
+!> @param[in] ismpl local sample index
+!> @details
+!> Check the local/current PROPS ldef_props against the PROPS choice
+!> in the input file (def_props).
+ subroutine props_check(ismpl)
+ use mod_genrlc, only: def_props
+
+ implicit none
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Local PROPS
+ character (len=10), parameter :: ldef_props = 'const'
+
+ ! Test options of command line input
+ logical, external :: test_option
+
+ intrinsic trim
+
+
+#ifndef PROPS_const
+ write(*,'(3A)') 'error: this source was written for PROPS=', &
+ ldef_props, &
+ ', please correct this check in "props_check.f"!'
+ stop
+#endif
+ if ( .not. test_option('PROPS='//trim(def_props))) then
+ if (ldef_props/=def_props) then
+ write(*,'(7A)') 'Error: model file needs an executable', &
+ ' build from PROPS=', trim(def_props), &
+ ', but the current', ' consist of PROPS=', &
+ trim(ldef_props), '!'
+ stop
+ end if
+ end if
+
+ return
+
+ end subroutine props_check
diff --git a/props/const/props_end.f90 b/props/const/props_end.f90
new file mode 100644
index 0000000..5368656
--- /dev/null
+++ b/props/const/props_end.f90
@@ -0,0 +1,37 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief wrapper finishing property module
+!> @param[in] ismpl local sample index
+!> @details
+!> For const: Dummy Wrapper.
+ subroutine props_end(ismpl)
+
+ implicit none
+
+ ! Sample index
+ integer :: ismpl
+
+
+ return
+
+ end subroutine props_end
diff --git a/props/const/props_init.f90 b/props/const/props_init.f90
new file mode 100644
index 0000000..c583244
--- /dev/null
+++ b/props/const/props_init.f90
@@ -0,0 +1,41 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief wrapper initializing property module
+!> @param[in] ismpl local sample index
+!> @details
+!> Wrapper for calling read_props and check_props.
+ subroutine props_init(ismpl)
+
+ implicit none
+
+ ! Sample index
+ integer :: ismpl
+
+
+ CALL read_props(ismpl)
+
+ CALL check_props(ismpl)
+
+ return
+
+ end subroutine props_init
diff --git a/props/const/qc.f90 b/props/const/qc.f90
new file mode 100644
index 0000000..dc3b9e0
--- /dev/null
+++ b/props/const/qc.f90
@@ -0,0 +1,55 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign transport production to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] spec species index
+!> @param[in] ismpl local sample index
+!> @return transport production
+!> @details
+!> Assign transport production to cell. \n\n
+!>
+!> Hardcoded to zero, use only if you really know that you want
+!> transport production to exist.\n
+ double precision function qc(i,j,k,spec,ismpl)
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Species index
+ integer, intent (in) :: spec
+
+ ! Sample index
+ integer :: ismpl
+
+ ! No transport production
+ qc = 0.0d0
+
+ return
+
+ end function qc
diff --git a/props/const/qf.f90 b/props/const/qf.f90
new file mode 100644
index 0000000..6ed3011
--- /dev/null
+++ b/props/const/qf.f90
@@ -0,0 +1,50 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign flow production to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return flow production
+!> @details
+!> Assign flow production to cell. \n\n
+!>
+!> Hardcoded to zero, use only if you really know that you want
+!> flow production to exist.\n
+ double precision function qf(i,j,k,ismpl)
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ qf = 0.0d0
+
+ return
+
+ end function qf
diff --git a/props/const/qt.f90 b/props/const/qt.f90
new file mode 100644
index 0000000..284f102
--- /dev/null
+++ b/props/const/qt.f90
@@ -0,0 +1,51 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign heat production to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return heat production
+!> @details
+!> qt returns the heat production [W/m3] at node(i,j,k) from the
+!> input file.\n
+ double precision function qt(i,j,k,ismpl)
+
+ use arrays, only: propunit, uindex, idx_q
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ qt = propunit(uindex(i,j,k),idx_q,ismpl)
+
+ return
+
+ end function qt
diff --git a/props/const/rce.f90 b/props/const/rce.f90
new file mode 100644
index 0000000..4811222
--- /dev/null
+++ b/props/const/rce.f90
@@ -0,0 +1,84 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates volumetric heat capacity of the cell
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return volumetric heat capacity
+!> @details
+!> calculates volumetric heat capacity of the system
+!> matrix-porosity [J/(K*m3)].\n
+ double precision function rhoceff(i,j,k,ismpl)
+
+ use arrays, only: temp
+ ! use mod_temp
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Local temperature [degC]
+ double precision :: tlocal
+
+ ! Local porosity [-]
+ double precision :: porlocal
+ double precision, external :: por
+
+ ! Matrix fraction in cell
+ double precision :: fm
+
+ ! Fluid fraction in cell
+ double precision :: ff
+
+ ! Heat capacity of the matrix
+ double precision, external :: rhocm
+
+ ! Heat capacity of the fluid
+ double precision, external :: rhocf
+
+
+ ! Local Temperature in degC
+ tlocal = temp(i,j,k,ismpl)
+
+ ! Local porosity
+ porlocal = por(i,j,k,ismpl)
+
+ ! Matrix fraction
+ fm = 1.D0 - porlocal
+
+ ! Fluid fraction
+ ff = porlocal
+
+ ! Heat capacity in cell, arithmetic mean
+ rhoceff = ff*rhocf(i,j,k,ismpl) + fm*rhocm(i,j,k,ismpl)
+
+ return
+
+ end function rhoceff
diff --git a/props/const/read_props.f90 b/props/const/read_props.f90
new file mode 100644
index 0000000..206ba6c
--- /dev/null
+++ b/props/const/read_props.f90
@@ -0,0 +1,116 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief read user defined additionally parameter
+!> @param[in] ismpl local sample index
+ subroutine read_props(ismpl)
+ use arrays
+ use mod_flow, only: rref
+ use mod_genrl
+ use mod_genrlc, only: project
+ use mod_const, only: npropsf, fprops, pconst_rhof, &
+ pconst_compf, pconst_cpf, pconst_lamf, pconst_visf
+ use mod_linfos, only: linfos
+
+ implicit none
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Filename of input file
+ character (len=80) :: filename
+
+ ! String of curretly read line from input file
+ character (len=80) :: line
+
+ ! Index
+ integer :: i
+
+ ! String utilities
+ integer, external :: lblank
+ logical, external :: found
+
+ ! External input utility
+ logical, external :: no_ext_link
+
+
+ ! Set filename
+ filename = project(:lblank(project))
+ write(*,*) ' '
+ write(*,*) ' reading constant fluid properties:'
+ write(*,*) ' from file "', filename, '"'
+ write(*,*) ' '
+
+ ! open project config file
+ open(79,file=filename,status='old')
+
+ ! input from keyword '# fluid props'
+ if (found(79,key_char//' fluid props',line,.false.)) then
+ read(79,*) (fprops(i),i=1,npropsf)
+
+ if (linfos(3)>=1) then
+ write(*,*) ' [R] : constant fluid properties'
+ write(*,*) ' '
+ write(*,'(a,/a,a)') ' fluid properties: ', &
+ ' rhof compf cpf lamf', &
+ ' visf'
+ write(*,'(6e12.4)') (fprops(i),i=1,npropsf)
+ write(*,*) ' '
+ end if
+
+ else
+
+ ! default fluid density
+ fprops(pconst_rhof) = 998.0d0
+ ! default fluid compressibility
+ fprops(pconst_compf) = 5.0d-8
+ ! default fluid volumetric heat capacity (rho*c)
+ fprops(pconst_cpf) = 4218.0d0
+ ! default fluid thermal conductivity
+ fprops(pconst_lamf) = 0.65d0
+ ! default fluid viscosity
+ fprops(pconst_visf) = 1.0d-3
+
+ write(*,*) ' [D] : constant fluid properties assumed'
+ write(*,*) ' '
+
+ if (linfos(3)>=1) then
+ write(*,'(a,/a,a)') ' fluid properties: ', &
+ ' rhof compf cpf lamf', &
+ ' visf'
+ write(*,'(6e12.4)') (fprops(i),i=1,npropsf)
+ write(*,*) ' '
+ end if
+
+ end if
+
+ ! Overwriting rref with the constant density read in this file
+ write(*,*) ' [?] : WARNING: overwrite "rref" with constant "rhof"'
+ rref = fprops(pconst_rhof)
+
+
+ ! close project config file
+ close(79)
+
+ return
+
+ end subroutine read_props
diff --git a/props/const/rhocf.f90 b/props/const/rhocf.f90
new file mode 100644
index 0000000..92060b2
--- /dev/null
+++ b/props/const/rhocf.f90
@@ -0,0 +1,47 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates heat capacity*density of the fluid.
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return rhocf rc[W/(m*K)]
+ double precision function rhocf(i,j,k,ismpl)
+ use mod_const, only: fprops, pconst_cpf, pconst_rhof
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ rhocf = fprops(pconst_cpf)*fprops(pconst_rhof)
+
+ return
+
+ end function rhocf
diff --git a/props/const/rhocm.f90 b/props/const/rhocm.f90
new file mode 100644
index 0000000..e674ce8
--- /dev/null
+++ b/props/const/rhocm.f90
@@ -0,0 +1,50 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates heat capacity*density of rock
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return heat capacity*density = volumetric heat capacity rhocm [J/(K*m3)]
+!> @details
+!> rhocm returns the volumetric heat capacity [J/(K*m3)] at
+!> node(i,j,k) from the input file.\n
+ double precision function rhocm(i,j,k,ismpl)
+ use arrays, only: propunit, uindex, idx_rc
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ rhocm = propunit(uindex(i,j,k),idx_rc,ismpl)
+
+ return
+
+ end function rhocm
diff --git a/props/const/rhof.f90 b/props/const/rhof.f90
new file mode 100644
index 0000000..8a699ec
--- /dev/null
+++ b/props/const/rhof.f90
@@ -0,0 +1,51 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates density of the fluid
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return rho [kg/m^3]
+!> @details
+!> input:\n
+!> rhof returns the density of the fluid [kg/m3] at node(i,j,k) from the
+!> input file.\n
+ double precision function rhof(i,j,k,ismpl)
+ use mod_const, only: fprops, pconst_rhof
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ rhof = fprops(pconst_rhof)
+
+ return
+
+ end function rhof
diff --git a/props/const/visf.f90 b/props/const/visf.f90
new file mode 100644
index 0000000..13ea3f9
--- /dev/null
+++ b/props/const/visf.f90
@@ -0,0 +1,50 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief returns viscosity of the fluid
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return visf[Pa s]
+!> @details
+!> visf returns the viscosity of the fluid [Pa s] at node(i,j,k) from the
+!> input file.\n\n
+ double precision function visf(i,j,k,ismpl)
+ use mod_const, only: fprops, pconst_visf
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ visf = fprops(pconst_visf)
+
+ return
+
+ end function visf
diff --git a/props/ghe/check_domain.f90 b/props/ghe/check_domain.f90
new file mode 100644
index 0000000..03181e3
--- /dev/null
+++ b/props/ghe/check_domain.f90
@@ -0,0 +1,188 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief domain of validity for module ghe
+!> @param[in] ismpl local sample index
+!> @details
+!> Checking whether pres/temp/(conc) are in domain of props
+!> validity. Version for property module ghe. \n
+!> \n
+!> For concentration, an error is thrown and the execution is
+!> stopped if the concentration is outside the physical values.
+ subroutine check_domain(ismpl)
+ use arrays, only: pres, temp, conc
+ use mod_genrl, only: i0, j0, k0
+ use mod_genrlc, only: def_props
+ use mod_conc, only: ntrac
+ use mod_linfos, only: linfos
+
+ implicit none
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Iteration counters
+ integer :: i, j, k, l
+
+ ! counters for the values outside domain of validity
+ ! pres
+ integer :: icountp
+ ! temp
+ integer :: icountt
+ ! conc
+ integer :: icountc
+
+ ! min/max boundaries of the domain of validity
+ ! pres
+ double precision, parameter :: pmin = 0.01d6
+ double precision, parameter :: pmax = 110.0d6
+ ! temp
+ double precision, parameter :: tmin = 0.0d0
+ double precision, parameter :: tmax = 350.0d0
+ ! conc
+ double precision, parameter :: cmin = 0.0d0
+ double precision, parameter :: cmax = 1.0d5
+ ! numerical boundary
+ double precision, parameter :: csmin = 1.0d-22
+
+ ! records the overall min/max of values if they are outside
+ ! domain of validity
+ double precision :: dpmax, dtmax, dcmax, dhmax
+ double precision :: dpmin, dtmin, dcmin, dhmin
+
+ intrinsic trim
+
+
+ ! Set counters to zero
+ icountp = 0
+ icountt = 0
+ icountc = 0
+
+ ! Set overall min/max to boundaries of the domain of validity
+ dpmax = pmax
+ dpmin = pmin
+ dtmax = tmax
+ dtmin = tmin
+ dcmax = cmax
+ dcmin = cmin
+
+ ! Check pres
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ if (pres(i,j,k,ismpl)<pmin) then
+ ! Set min counter
+ icountp = icountp + 1
+ ! Set new overall minimum
+ dpmin = min(dpmin,pres(i,j,k,ismpl))
+ ! Change pres value to minimum of the domain of validity
+ pres(i,j,k,ismpl) = pmin
+ end if
+ if (pres(i,j,k,ismpl)>pmax) then
+ ! Set max counter
+ icountp = icountp + 1
+ ! Set new overall maximum
+ dpmax = max(dpmax,pres(i,j,k,ismpl))
+ ! Change pres value to maximum of the domain of validity
+ pres(i,j,k,ismpl) = pmax
+ end if
+ end do
+ end do
+ end do
+
+ ! Check temp
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ if (temp(i,j,k,ismpl)<tmin) then
+ icountt = icountt + 1
+ dtmin = min(dtmin,temp(i,j,k,ismpl))
+ temp(i,j,k,ismpl) = tmin
+ end if
+ if (temp(i,j,k,ismpl)>tmax) then
+ icountt = icountt + 1
+ dtmax = max(dtmax,temp(i,j,k,ismpl))
+ temp(i,j,k,ismpl) = tmax
+ end if
+ end do
+ end do
+ end do
+
+ ! Check conc
+ do k = 1, k0
+ do j = 1, j0
+ do i = 1, i0
+ do l = 1, ntrac
+ if (conc(i,j,k,l,ismpl).gt.cmax) then
+ icountc = icountc +1
+ dcmax = max(dcmax, conc(i,j,k,l,ismpl))
+ conc(i,j,k,l,ismpl) = cmax
+ end if
+ if (conc(i,j,k,l,ismpl)<cmin .and. &
+ conc(i,j,k,l,ismpl)<-csmin) then
+ icountc = icountc + 1
+ dcmin = min(dcmin,conc(i,j,k,l,ismpl))
+ conc(i,j,k,l,ismpl) = cmin
+ end if
+ if (conc(i,j,k,l,ismpl)<csmin) then
+ ! very small conc values set to zero to avoid
+ ! numerically instabilities
+ conc(i,j,k,l,ismpl) = cmin
+ end if
+ end do
+ end do
+ end do
+ end do
+
+! disable the warning output for linfos(3)==-1
+ if (linfos(3)>=0) then
+ if (icountp/=0) write(*,'(3A,1I8,1A,1e16.7,1A,1e16.7,1A)') &
+ 'warning: pres not in domain of validity of module <', &
+ trim(def_props), '> at ', icountp, ' points (min', dpmin, &
+ ', max', dpmax, ')!'
+ if (icountt/=0) write(*,'(3A,1I8,1A,1e16.7,1A,1e16.7,1A)') &
+ 'warning: temp not in domain of validity of module <', &
+ trim(def_props), '> at ', icountt, ' points (min', dtmin, &
+ ', max', dtmax, ')!'
+ if (icountc/=0) write(*,'(3A,1I8,1A,1e16.7,1A,1e16.7,1A)') &
+ 'warning: conc not in domain of validity of module <', &
+ trim(def_props), '> at ', icountc, ' points (min', dcmin, &
+ ', max', dcmax, ')!'
+
+ ! error outputs for hard physical concentration boundaries
+ if (dcmax > cmax) then
+ write(unit = *, fmt = *) "[E1] Error in check_domain.f90:", &
+ " maximum concentration dcmax= ", dcmax, &
+ " larger than allowed maximum value cmax=", cmax
+ stop
+ end if
+ if (dcmin > cmin) then
+ write(unit = *, fmt = *) "[E2] Error in check_domain.f90:", &
+ " minimum concentration dcmin= ", dcmin, &
+ " smaller than allowed minimum value cmin=", cmin
+ stop
+ end if
+ end if
+
+ return
+
+ end subroutine check_domain
diff --git a/props/ghe/compf.f90 b/props/ghe/compf.f90
new file mode 100644
index 0000000..86340b0
--- /dev/null
+++ b/props/ghe/compf.f90
@@ -0,0 +1,192 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief compf calculates compressibility of pure water
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return compressibility compf [1./Pa]
+!> @details
+!> compf calculates compressibility of pure water \n
+!> given temperature (t, in C), and pressure (p,in Pa)\n
+!> at node(i,j,k).\n \n
+!>
+!> Method: \n
+!>
+!> compf = 1/rhof d/dP rhof, \n
+!>
+!> where rhof= water density.\n \n
+!>
+!> Main source of rhof (water density) approximation, see
+!> props/ghe/rhof.f90. \n \n
+!>
+!> range of validity:\n
+!> - pressures 0.001 - 110 MPa,\n
+!> - temperature 15 - 360 degC\n
+ double precision function compf(i,j,k,ismpl)
+ use arrays, only: temp, pres
+ use mod_flow, only: pa_conv, pa_conv1
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Temperature (degC)
+ double precision :: tlocal
+
+ ! Pressure (MPa)
+ double precision :: plocal
+
+ ! Monomials of temperature and pressure
+ double precision :: t, t2, t3
+ double precision :: p, p2, p3, p4
+ double precision :: tp, t2p, tp2
+
+ ! Coefficients of numerator of rational function approximation
+ double precision, parameter :: Y0 = 0.10000000D+01
+ double precision, parameter :: Y1 = 0.17472599D-01
+ double precision, parameter :: Y2 = -0.20443098D-04
+ double precision, parameter :: Y3 = -0.17442012D-06
+ double precision, parameter :: Y4 = 0.49564109D-02
+ double precision, parameter :: Y5 = -0.40757664D-04
+ double precision, parameter :: Y6 = 0.50676664D-07
+ double precision, parameter :: Y7 = 0.50330978D-04
+ double precision, parameter :: Y8 = 0.33914814D-06
+ double precision, parameter :: Y9 = -0.18383009D-06
+
+ ! Coefficients of denominator of rational function approximation
+ double precision, parameter :: Z0 = 0.10009476D-02
+ double precision, parameter :: Z1 = 0.16812589D-04
+ double precision, parameter :: Z2 = -0.24582622D-07
+ double precision, parameter :: Z3 = -0.17014984D-09
+ double precision, parameter :: Z4 = 0.48841156D-05
+ double precision, parameter :: Z5 = -0.32967985D-07
+ double precision, parameter :: Z6 = 0.28619380D-10
+ double precision, parameter :: Z7 = 0.53249055D-07
+ double precision, parameter :: Z8 = 0.30456698D-09
+ double precision, parameter :: Z9 = -0.12221899D-09
+
+ ! Numerator and denominator of rational function approximation
+ double precision :: ta, tb
+
+ ! Derivative of numerator wrt P
+ double precision :: da
+
+ ! Derivative of denominator wrt P
+ double precision :: db
+
+ ! Denominator squared
+ double precision :: b2
+
+ ! Water density (local)
+ double precision :: rhof_loc
+
+ ! Derivative of water density wrt P
+ double precision :: drhodp
+
+ ! Compressibiliy in Mpa
+ double precision :: compf_mpa
+
+
+ ! Local Pressure in MPa
+ plocal = pres(i,j,k,ismpl)*pa_conv1
+
+ ! Local Temperature in degC
+ tlocal = temp(i,j,k,ismpl)
+
+ ! Temperature out of bounds
+ if (tlocal > 360.0d0) then
+ write (*,*) "[E1]: Error: Temperature (",&
+ tlocal,") out of bounds (> 360 degC) at ", i,j,k
+ stop
+ end if
+ if (tlocal < 0.0d0) then
+ ! Relax table boundary of 15degC to error boundary 0degC
+ write (*,*) "[E2]: Error: Temperature (",&
+ tlocal,") out of bounds (< 0 degC) at ", i,j,k
+ stop
+ end if
+
+ ! Pressure out of bounds
+ if (plocal > 110.0d0) then
+ write (*,*) "[E3]: Error: Pressure (",&
+ plocal,") out of bounds (> 110 MPa) at ", i,j,k
+ stop
+ end if
+ if (plocal < 0.001d0) then
+ write (*,*) "[E4]: Error: Pressure (",&
+ plocal,") out of bounds (< 0.001 MPa) at ", i,j,k
+ stop
+ end if
+
+ ! Compute monomials in pressure and temperature
+ p = plocal
+ t = tlocal
+ p2 = p*p
+ p3 = p2*p
+ p4 = p3*p
+ t2 = t*t
+ t3 = t2*t
+ tp = p*t
+ tp2 = t*p2
+ t2p = t2*p
+
+ ! Numerator of rational function approximation
+ ta = Y0 + Y1*p + Y2*p2 + Y3*p3 + Y4*t + &
+ Y5*t2 + Y6*t3 + Y7*tp + Y8*tp2 + Y9*t2p
+
+ ! Denominator of rational function approximation
+ tb = Z0 + Z1*p + Z2*p2 + Z3*p3 + Z4*t + &
+ Z5*t2 + Z6*t3 + Z7*tp + Z8*tp2 + Z9*t2p
+
+ ! Water density
+ rhof_loc = ta/tb
+
+ ! Derivative of numerator
+ da = Y1 + 2.D0*Y2*p + 3.D0*Y3*p2 + Y7*t + &
+ 2.D0*Y8*tp + Y9*t2
+
+ ! Derivative of denominator
+ db = Z1 + 2.D0*Z2*p + 3.D0*Z3*p2 + Z7*t + &
+ 2.0*Z8*tp + Z9*t2
+
+ ! Denominator squared
+ b2 = tb*tb
+
+ ! Derivative, quotient rule
+ drhodp = (da*tb-ta*db)/b2
+
+ ! Compressibility: (1/rhof_loc) * drhodp [1/MPa]
+ compf_mpa = drhodp/rhof_loc
+
+ ! Compressibility [1/Pa]
+ compf = compf_mpa / pa_conv
+
+ return
+ end function compf
diff --git a/props/ghe/compm.f90 b/props/ghe/compm.f90
new file mode 100644
index 0000000..977e772
--- /dev/null
+++ b/props/ghe/compm.f90
@@ -0,0 +1,50 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief compm returns the compressibility of rock matrix
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return compressibility of rock [1/Pa]
+!> @details
+!> compm returns the compressibility [1/Pa] at node(i,j,k) from the
+!> input file.\n
+ double precision function compm(i,j,k,ismpl)
+ use arrays, only: propunit, uindex, idx_comp
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ compm = propunit(uindex(i,j,k),idx_comp,ismpl)
+
+ return
+
+ end function compm
diff --git a/props/ghe/cpf.f90 b/props/ghe/cpf.f90
new file mode 100644
index 0000000..35568f7
--- /dev/null
+++ b/props/ghe/cpf.f90
@@ -0,0 +1,198 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief cpf(i,j,k,ismpl) calculates the isobaric heat capacity in (in J/kg/K)
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return cpf [J/kg/K]
+!> @details
+!> cpf(i,j,k,ismpl) calculates the isobaric heat capacity in (in
+!> J/kg/K)\n of pure water, given temperature (t, in C), and
+!> pressure (p,in Pa)\n at node(i,j,k).\n \n
+!>
+!> method: c_p = d/dT E, E= fluid enthalpy.\n \n
+!>
+!> Main source Zyvoloski1997: \n
+!>
+!> Zyvoloski, G.A., Robinson, B.A., Dash, Z.V., & Trease, L.L. Summary
+!> of the models and methods for the FEHM application - a
+!> finite-element heat- and mass-transfer code. United
+!> States. doi:10.2172/565545. \n \n
+!>
+!> Alternative source (same text, more modern, without doi): \n
+!> https://fehm.lanl.gov/orgs/ees/fehm/pdfs/fehm_mms.pdf \n \n
+!>
+!> The table of coefficients from Zyvoloski1997 describes the physical
+!> values found in Haar1984: \n
+!>
+!> Lester Haar, John Gallagher, George Kell, NBS/NRC Steam Tables:
+!> Thermodynamic and Transport Properties and Computer Programs for
+!> Vapor and Liquid States of Water in SI Units, Hemisphere Publishing
+!> Corporation, Washington, 1984. \n \n
+!>
+!> range of validity:\n
+!> pressures 0.001 - 110 MPa,\n
+!> temperature 15 - 350 degC\n
+ double precision function cpf(i,j,k,ismpl)
+ use arrays, only: pres, temp
+ use mod_flow, only: pa_conv1
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Temperature (degC)
+ double precision :: tlocal
+
+ ! Pressure (MPa)
+ double precision :: plocal
+
+ ! Enthalpy (J/kg)
+ double precision :: enth
+
+ ! Derivative of enthalpy wrt T (J/kg/K)
+ double precision :: denthdt
+
+ ! Monomials of temperature and pressure
+ double precision :: t, t2, t3
+ double precision :: p, p2, p3, p4
+ double precision :: tp, t2p, tp2
+
+ ! Coefficients of numerator of rational function approximation
+ double precision, parameter :: Y0 = 0.25623465D-3
+ double precision, parameter :: Y1 = 0.10184405D-2
+ double precision, parameter :: Y2 = 0.22554970D-4
+ double precision, parameter :: Y3 = 0.34836663D-7
+ double precision, parameter :: Y4 = 0.41769866D-2
+ double precision, parameter :: Y5 = -0.21244879D-4
+ double precision, parameter :: Y6 = 0.25493516D-7
+ double precision, parameter :: Y7 = 0.89557885D-4
+ double precision, parameter :: Y8 = 0.10855046D-6
+ double precision, parameter :: Y9 = -0.21720560D-6
+
+ ! Coefficients of denominator of rational function approximation
+ double precision, parameter :: Z0 = 0.10000000D+1
+ double precision, parameter :: Z1 = 0.23513278D-1
+ double precision, parameter :: Z2 = 0.48716386D-4
+ double precision, parameter :: Z3 = -0.19935046D-8
+ double precision, parameter :: Z4 = -0.50770309D-2
+ double precision, parameter :: Z5 = 0.57780287D-5
+ double precision, parameter :: Z6 = 0.90972916D-9
+ double precision, parameter :: Z7 = -0.58981537D-4
+ double precision, parameter :: Z8 = -0.12990752D-7
+ double precision, parameter :: Z9 = 0.45872518D-8
+
+ ! Numerator and denominator of rational function approximation
+ double precision :: ta, tb
+
+ ! Derivative of numerator wrt T
+ double precision :: da
+
+ ! Derivative of denominator wrt T
+ double precision :: db
+
+ ! Denominator squared
+ double precision :: b2
+
+
+ ! Local Pressure in MPa
+ plocal = pres(i,j,k,ismpl)*pa_conv1
+
+ ! Local Temperature in degC
+ tlocal = temp(i,j,k,ismpl)
+
+ ! Temperature out of bounds
+ if (tlocal > 360.0d0) then
+ write (*,*) "[E1]: Error: Temperature (",&
+ tlocal,") out of bounds (> 360 degC) at ", i,j,k
+ stop
+ end if
+ if (tlocal < 0.0d0) then
+ ! Relax table boundary of 15degC to error boundary 0degC
+ write (*,*) "[E2]: Error: Temperature (",&
+ tlocal,") out of bounds (< 0 degC) at ", i,j,k
+ stop
+ end if
+
+ ! Pressure out of bounds
+ if (plocal > 110.0d0) then
+ write (*,*) "[E3]: Error: Pressure (",&
+ plocal,") out of bounds (> 110 MPa) at ", i,j,k
+ stop
+ end if
+ if (plocal < 0.001d0) then
+ write (*,*) "[E4]: Error: Pressure (",&
+ plocal,") out of bounds (< 0.001 MPa) at ", i,j,k
+ stop
+ end if
+
+ ! Compute monomials in pressure and temperature
+ p = plocal
+ t = tlocal
+ p2 = p*p
+ p3 = p2*p
+ p4 = p3*p
+ t2 = t*t
+ t3 = t2*t
+ tp = p*t
+ tp2 = t*p2
+ t2p = t2*p
+
+ ! Numerator of rational function approximation
+ ta = Y0 + Y1*p + Y2*p2 + Y3*p3 + Y4*t + &
+ Y5*t2 + Y6*t3 + Y7*tp + Y8*tp2 + Y9*t2p
+
+ ! Denominator of rational function approximation
+ tb = Z0 + Z1*p + Z2*p2 + Z3*p3 + Z4*t + &
+ Z5*t2 + Z6*t3 + Z7*tp + Z8*tp2 + Z9*t2p
+
+ ! Enthalpy
+ enth = ta/tb
+
+ ! Derivative of numerator
+ da = Y4 + 2.0d0*Y5*t + 3.0d0*Y6*t2 + Y7*p + &
+ Y8*p2 + 2.0d0*Y9*tp
+
+ ! Derivative of denominator
+ db = Z4 + 2.0d0*Z5*t + 3.0d0*Z6*t2 + Z7*p + &
+ Z8*p2 + 2.0d0*Z9*tp
+
+ ! Denominator squared
+ b2 = tb*tb
+
+ ! Derivative, quotient rule
+ denthdt = da/tb - ta*db/b2
+
+ ! Isobaric heat capacity (J/kg/K)
+ cpf = denthdt*1.0d6
+
+ return
+
+ end function cpf
diff --git a/props/ghe/disp.f90 b/props/ghe/disp.f90
new file mode 100644
index 0000000..36737bf
--- /dev/null
+++ b/props/ghe/disp.f90
@@ -0,0 +1,50 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign effective diffusivity z direction to cell
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return assign effective diffusivity
+!> @details
+!> assign effective diffusivity, called dispersivity in the input
+!> file.
+ double precision function disp(i,j,k,ismpl)
+ use arrays, only: propunit, uindex, idx_df
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ disp = propunit(uindex(i,j,k),idx_df,ismpl)
+
+ return
+
+ end function disp
diff --git a/props/ghe/ghe_array.f90 b/props/ghe/ghe_array.f90
new file mode 100644
index 0000000..ba2cb7c
--- /dev/null
+++ b/props/ghe/ghe_array.f90
@@ -0,0 +1,54 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+ MODULE work_array_ghe
+
+
+
+! IMPLICIT NONE
+
+
+
+ DOUBLE PRECISION, ALLOCATABLE :: Tu(:,:,:), Td(:,:,:), &
+ Tout(:,:,:), Tin_new(:,:), Tin(:,:), dTsghe(:), Hghe(:,:),&
+ dTs(:), Tsghe(:,:), qshe(:,:,:), dTsgheprime(:), &
+ Tsghe_old(:,:), pghe(:,:), Temp_flip(:,:,:), H_flip(:,:,:), &
+ pres_flip(:,:,:), Ts(:,:), dTsdepth(:), ypp(:), press(:,:), &
+ Tsspline(:), pressspline(:), lagrange(:,:,:), yppq(:), &
+ dpres(:,:)
+
+ INTEGER nt, nghe, tWRITE2, time, endtime, ng, it, k_p, iper, &
+ tWRITE, np, nr, modswitch
+ INTEGER, ALLOCATABLE :: ighe(:),jghe(:),fghe(:),k_end(:), &
+ k_start(:)
+ DOUBLE PRECISION QF, kw, Cpw, Dw, ru, dz, ruo, Bu, ks, kfill, &
+ r1, fluid_type, deltatime, ntdouble, Cpwu, Dwu, Cpwd, Dwd, &
+ depthup, kwd, kwu, dy, Cpwi, Dwi, kwi, kinvisci, &
+ time_count, dghe
+
+ DOUBLE PRECISION, ALLOCATABLE :: rdu(:), rd(:), rgr(:), ku(:), &
+ kd(:), kgr(:), Rdb(:), Rudu(:), Rdown(:), Rup(:), Ru_du_cd(:),&
+ Rb_d_cd(:), depth(:),rb(:)
+
+ INTEGER mp,nl,p, fup, kdepth, ghetype, kl ! l
+
+ END MODULE work_array_ghe
diff --git a/props/ghe/ghe_hpr.f90 b/props/ghe/ghe_hpr.f90
new file mode 100644
index 0000000..650d351
--- /dev/null
+++ b/props/ghe/ghe_hpr.f90
@@ -0,0 +1,161 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!************************************************************************
+!***** *****
+!***** *****
+!***** *****
+!************************************************************************
+!***** *****
+!***** THIS PROGRAM APPRXIMATES THE EFFECT OF GHE ON THE SUBSURFACE*****
+!***** *****
+!***** BY USING AN EFFECTIVE HEAT PRODUCTION *****
+!***** *****
+!***** *****
+!***** dm 270808 modified by jh and rs and dm 250112 *****
+!************************************************************************
+!*
+!**********************************************************************
+ SUBROUTINE GHE_HPROD
+ USE arrays
+ USE work_array_ghe
+ USE mod_genrl
+ USE mod_genrlc
+! IMPLICIT NONE
+
+ DOUBLE PRECISION depth_hpr
+
+! Alle Sonden gleich...zun�chst
+ ALLOCATE(dTs(K0))
+
+! READ all geometrical borehole parameters************************
+ WRITE(*,*) "geometry"
+
+ OPEN(1,FILE='ghe_new.par')
+
+! Anzahl der GHE
+ READ(1,*) nghe
+
+ READ(1,*) depth_hpr !
+
+! i Stelle GHEs
+ ALLOCATE(ighe(nghe))
+
+! j Stelle GHEs
+ ALLOCATE(jghe(nghe))
+
+! Sondenkopf an der Erdoberfl�che im Modell (k von Shemat)
+ ALLOCATE(k_end(nghe))
+
+! Sondenfu� (k von Shemat)
+ ALLOCATE(k_start(nghe))
+
+! Ort(e) der Sonden
+ READ(1,*) (ighe(i), jghe(i),k_end(i),i=1,nghe)
+ CLOSE(1)
+
+ WRITE(*,*) nghe
+ DO nl=1,nghe
+ WRITE(*,*) ighe(nl),jghe(nl)
+ END DO
+
+ OPEN(2,FILE='ghe_ini_new.ini')
+
+! Anzahl der Perioden
+ READ(2,*) iper
+ WRITE(*,*)
+ WRITE(*,*) ' READING NEW Ground Heat Exchanger model parameters'
+ WRITE(*,*)
+ WRITE(*,*) 'Anzahl der Perioden', iper
+
+ ALLOCATE(Tin(iper,4))
+
+! Periode (h), Flow an/aus, Leistung (NEU: Leistung (kW) im Gesamtfeld!)
+ READ(2,*) (Tin(i,1),Tin(i,2),Tin(i,3),i=1,iper)
+ CLOSE(2)
+
+! Zeiten in Sekunden
+ Tin(1,1)=Tin(1,1)*3600.0d0
+
+ DO i=2,iper
+ Tin(i,1)=Tin(i,1)*3600.0d0+Tin(i-1,1)
+ END DO
+! auf Sonde und Tiefe verteilt...spaeter Hprod
+ DO i=1,iper
+ Tin(i,3)=Tin(i,3)/nghe/depth_hpr
+ END DO
+!----------------% ende einlesen ini------
+
+! Hier muss die Anzahl der Sonden ber�cksichtigt werden!
+
+! ANFANG SCHLEIFE �BER SONDEN #######################
+ DO nl=1,nghe
+! hier wird variable Tiefe der Sonden gesetzt
+ k_start(nl)=k_end(nl)-depth_hpr/delz(1)+1
+ ! k_end(nl)=K0-k_end(nl)
+
+ WRITE(*,*), 'kdepth', k_start(nl), k_end(nl)
+! DO k=k_end(n),k_start(n)
+!! setze permeabilitaet an den sonden kl
+! kx(ighe(n),jghe(n),K0-k+1,ismpl)=1e-25
+! ky(ighe(n),jghe(n),K0-k+1,ismpl)=1e-25
+! kz(ighe(n),jghe(n),K0-k+1,ismpl)=1e-25
+! END DO
+!
+ END DO
+!! ENDE SCHLEIFE �BER SONDEN. #########################
+
+! F�r n�chste Routine.
+ mp=1
+ END SUBROUTINE
+
+
+!*******ONE TIME STEP***********************************************************
+
+! SUBROUTINE GHETIMESTEP_HPR()
+! USE work_array_ghe
+! implicit none
+
+! IF (sdelt.le.Tin(m,1)) THEN
+! m=m
+! ELSE
+! m=m+1
+! END IF
+! WRITE(*,*),Tin(m,1)
+
+!! Anfang Schleife �ber Sonden
+! DO n=1,nghe
+! IF (Tin(m,2).ne.0) THEN ! An/aus
+! DO k=k_end(n),k_start(n)-1
+! qt(ighe(n),jghe(n),K0-k+1)=-Tin(m,3)*1000/&
+! (delx(ighe(n))*dely(jghe(n)))
+! END DO
+! ELSE
+! DO k=k_end(n),k_start(n)-1
+! qt(ighe(n),jghe(n),K0-k+1)=0
+! END DO
+! END IF
+! END DO
+!! Ende Schleife �ber Sonden
+
+! WRITE(*,*), 'Periode: (iper)' , m, 'Zeit', sdelt
+! END SUBROUTINE
diff --git a/props/ghe/kx.f90 b/props/ghe/kx.f90
new file mode 100644
index 0000000..2b272f0
--- /dev/null
+++ b/props/ghe/kx.f90
@@ -0,0 +1,72 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign permeability in x direction to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return permeability (m^2)
+!> @details
+!> kx returns the permeability in x-direction [m2] at node(i,j,k) from
+!> the input file.\n\n
+!>
+!> The permeability in x-direction is the product of the permeability
+!> in z-direction and the anisotropy factor for the x-direction.
+ double precision function kx(i,j,k,ismpl)
+ use arrays, only: propunit, uindex, idx_kz, idx_an_kx
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ kx = propunit(uindex(i,j,k),idx_kz,ismpl)* &
+ propunit(uindex(i,j,k),idx_an_kx,ismpl)
+
+! Wird das Setzen der Werte benoetigt?
+
+!! ANFANG SCHLEIFE �BER SONDEN #######################
+! DO n=1,nghe
+!! hier wird variable Tiefe der Sonden gesetzt
+! k_start(n)=K0-(k_end(n)-depth_hpr/delz(1))
+! k_end(n)=K0-k_end(n)
+!
+! WRITE(*,*), 'kdepth', k_start(n), k_end(n)
+! DO l=k_end(n),k_start(n)
+!! setze permeabilitaet an den sonden kl
+! IF (ighe(n).eq.i && jghe(n).eq.j && (K0-l+1).eq.k)
+! kx=1e-25
+! END IF
+! END DO
+! END DO
+!! ENDE SCHLEIFE �BER SONDEN. #########################
+
+ return
+
+ end function kx
diff --git a/props/ghe/ky.f90 b/props/ghe/ky.f90
new file mode 100644
index 0000000..c9e052b
--- /dev/null
+++ b/props/ghe/ky.f90
@@ -0,0 +1,72 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign permeability in y direction to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return permeability (m^2)
+!> @details
+!> ky returns the permeability in y-direction [m2] at node(i,j,k) from
+!> the input file.\n\n
+!>
+!> The permeability in y-direction is the product of the permeability
+!> in z-direction and the anisotropy factor for the y-direction.
+ double precision function ky(i,j,k,ismpl)
+ use arrays, only: propunit, uindex, idx_kz, idx_an_ky
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ ky = propunit(uindex(i,j,k),idx_kz,ismpl)* &
+ propunit(uindex(i,j,k),idx_an_ky,ismpl)
+
+! Wird das Setzen der Werte benoetigt?
+
+!! ANFANG SCHLEIFE �BER SONDEN #######################
+! DO n=1,nghe
+!! hier wird variable Tiefe der Sonden gesetzt
+! k_start(n)=K0-(k_end(n)-depth_hpr/delz(1))
+! k_end(n)=K0-k_end(n)
+!
+! WRITE(*,*), 'kdepth', k_start(n), k_end(n)
+! DO l=k_end(n),k_start(n)
+!! setze permeabilitaet an den sonden kl
+! IF (ighe(n).eq.i && jghe(n).eq.j && (K0-l+1).eq.k)
+! ky=1e-25
+! END IF
+! END DO
+! END DO
+!! ENDE SCHLEIFE �BER SONDEN. #########################
+
+ return
+
+ end function ky
diff --git a/props/ghe/kz.f90 b/props/ghe/kz.f90
new file mode 100644
index 0000000..0280f8e
--- /dev/null
+++ b/props/ghe/kz.f90
@@ -0,0 +1,69 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign permeability in z direction to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return permeability (m^2)
+!> @details
+!> kz returns the permeability in z-direction[m2] at node(i,j,k) from
+!> the input file.\n
+ double precision function kz(i,j,k,ismpl)
+ use arrays, only: propunit, uindex, idx_kz
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ kz = propunit(uindex(i,j,k),idx_kz,ismpl)
+
+
+! Wird das Setzen der Werte benoetigt?
+
+!! ANFANG SCHLEIFE �BER SONDEN #######################
+! DO n=1,nghe
+!! hier wird variable Tiefe der Sonden gesetzt
+! k_start(n)=K0-(k_end(n)-depth_hpr/delz(1))
+! k_end(n)=K0-k_end(n)
+!
+! WRITE(*,*), 'kdepth', k_start(n), k_end(n)
+! DO l=k_end(n),k_start(n)
+!! setze permeabilitaet an den sonden kl
+! IF (ighe(n).eq.i && jghe(n).eq.j && (K0-l+1).eq.k)
+! kz=1e-25
+! END IF
+! END DO
+! END DO
+!! ENDE SCHLEIFE �BER SONDEN. #########################
+
+ return
+
+ end function kz
diff --git a/props/ghe/lamf.f90 b/props/ghe/lamf.f90
new file mode 100644
index 0000000..ae283bd
--- /dev/null
+++ b/props/ghe/lamf.f90
@@ -0,0 +1,84 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculate the thermal conductivity kf in W/(m*K) of water
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return thermal conductivity [W/(m*K)]
+!> @details
+!> Calculate the thermal conductivity kf in W/(m*K) of freshwater,
+!> given temperature in degC. Thermal conductivity of freshwater, kfw
+!> is calculated using the Phillips (1981) formulation (page 8). \n\n
+!>
+!> Source:\n\n
+!>
+!> Phillips, S., Igbene, A., Fair, J., Ozbek, H., & Tavana, M.,
+!> Technical databook for geothermal energy utilization (1981).
+!> http://dx.doi.org/10.2172/6301274 \n\n
+!>
+!> Range of validity: 20 to 330 degC\n\n
+!>
+!> temperature tlocal in [C]\n
+ double precision function lamf(i,j,k,ismpl)
+ use arrays, only: temp
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Temperature (degC)
+ double precision :: tlocal
+
+ ! Monomials of temperatures quotient
+ double precision :: tr, tr2, tr3, tr4
+
+ ! Coefficients of approximation
+ double precision, parameter :: c0 = -0.92247d0
+ double precision, parameter :: c1 = 2.8395d0
+ double precision, parameter :: c2 = 1.8007d0
+ double precision, parameter :: c3 = 0.52577d0
+ double precision, parameter :: c4 = 0.07344d0
+
+
+ ! Local Temperature in degC
+ tlocal = temp(i,j,k,ismpl)
+
+ ! Monomials of temperature quotient
+ tr = (tlocal+273.15d0)/273.15d0
+ tr2 = tr*tr
+ tr3 = tr2*tr
+ tr4 = tr3*tr
+
+ ! Thermal conductivity [W/(m*K)]
+ lamf = (c0 + c1*tr - c2*tr2 + c3*tr3 - c4*tr4)
+
+ return
+
+ end function lamf
diff --git a/props/ghe/lamm.f90 b/props/ghe/lamm.f90
new file mode 100644
index 0000000..42ede46
--- /dev/null
+++ b/props/ghe/lamm.f90
@@ -0,0 +1,128 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculate temperature dependent thermal conductivity
+!> @param[in] lammref thermal conductivity from input file
+!> @param[in] tlocal temperature
+!> @param[in] tref reference temperature
+!> @param[in] ismpl local sample index
+!> @return temperature dependent thermal conductivity
+!> @details
+!> calculate temperature dependent thermal conductivity\n
+!>
+!> lam_zoth/haenel = (770degC/(350degC+T) + 0.7) W/mK
+!>
+!> If T > 800degC, use the formula from zoth & haenel, 1988. \n
+!>
+!> lamm = lam_zoth/haenel
+!>
+!> If T < 800degC, use the same formula with a factor `fct`
+!>
+!> lamm = fct * lam_zoth/haenel
+!>
+!> The factor `fct` introduces an additional temperature dependence
+!> such that\n
+!> 1. `lamm(20degC) = lammref`\n
+!> 2. `lamm(800degC) = lam_zoth/haenel(800degC)\n\n
+!>
+!> Thus, the thermal conductivity in the input file should resemble
+!> information about the value of the thermal conductivity of the
+!> matrix at temperature 20 degC.\n\n
+!>
+!> Sources: \n
+!> Zoth, G., & Haenel, R, Handbook of terrestrial heat-flow density
+!> determination, (1988), Appendix 10.1 Thermal
+!> Conductivity. http://dx.doi.org/10.1007/978-94-009-2847-3\n\n
+!>
+!> Lehmann, H., Wang, K., & Clauser, C., Parameter identification and
+!> uncertainty analysis for heat transfer at the ktb drill site using
+!> a 2-d inverse method, Tectonophysics, 291(1-4), 179–194
+!> (1998). Section 2.2 http://dx.doi.org/10.1016/s0040-1951(98)00039-0
+!> \n
+ double precision function lamm(lammref,tlocal,tref,ismpl)
+
+ implicit none
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Thermal conductivity of matrix at tref=20degC
+ double precision, intent (in) :: lammref
+
+ ! Local temperature [degC]
+ double precision, intent (in) :: tlocal
+
+ ! Reference temperature [20 degC]
+ double precision, intent (in) :: tref
+
+ ! Upper limit temperature, where the approximation becomes
+ ! equal to the general Zoth/Haenel formula
+ double precision, parameter :: tlimit = 800.0d0
+
+ ! lam_zoth/haenel at tlocal
+ double precision :: lamm_zh
+
+ ! lam_zoth/haenel at tref
+ double precision :: lamm_zhref
+
+ ! Reference Interpolation-factor
+ double precision :: fctref
+
+ ! Weight: Quotient of temperature differences
+ double precision :: twgt
+
+ ! Interpolation factor
+ double precision :: fct
+
+
+ if (tlocal > tlimit) then
+
+ ! lam_zoth/haenel at tlocal
+ lamm = 770.0d0/(350.0d0+tlocal) + 0.7D0
+
+ else
+
+ ! lam_zoth/haenel at tlocal
+ lamm_zh = 770.0d0/(350.0d0+tlocal) + 0.7d0
+
+ ! lam_zoth/haenel at tref
+ lamm_zhref = 770.0d0/(350.0d0+tref) + 0.7d0
+
+ ! Reference Interpolation-factor: Input lamm at tref divided
+ ! by lam_zoth/haenel at tref
+ fctref = lammref/lamm_zhref
+
+ ! Quotient of temperature differences, local minus reference
+ ! divided by limit minus reference
+ twgt = (tlocal-tref)/(tlimit-tref)
+
+ ! Interpolation factor between fctref at tref and 1 at tlimit
+ fct = fctref*(1-twgt) + twgt
+
+ ! Final lam: input at tref and lam_zoth/haenel at tlimit
+ lamm = fct*lamm_zh
+
+ end if
+
+ return
+
+ end function lamm
diff --git a/props/ghe/lx.f90 b/props/ghe/lx.f90
new file mode 100644
index 0000000..1d17aeb
--- /dev/null
+++ b/props/ghe/lx.f90
@@ -0,0 +1,66 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates effective thermal conductivity of the two phase
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return thermal conductivity lx[W/(m*K)]
+!> @details
+!> calculates effective thermal conductivity of the two phase\n
+!> system matrix-porosity .\n
+!> input:\n
+!> porosity porlocal [-]\n
+!> pressure plocal [pa]\n
+!> temperature tlocal in [C]\n
+ DOUBLE PRECISION FUNCTION lx(i,j,k,ismpl)
+ use arrays
+ use mod_temp
+ IMPLICIT NONE
+
+
+ INTEGER i, j, k, ui, ismpl
+ DOUBLE PRECISION plocal, tlocal, fluid, lamunit, lamf, &
+ porlocal, lamm
+ EXTERNAL lamf, lamm
+
+
+! ploCal = pres(i,j,k,ismpl)*Pa_Conv1
+ tlocal = temp(i,j,k,ismpl)
+ fluid = lamf(i,j,k,ismpl)
+ ui = uindex(i,j,k)
+ porlocal = propunit(ui,idx_por,ismpl)
+ lamunit = propunit(ui,idx_lz,ismpl)*propunit(ui,idx_an_lx, &
+ ismpl)
+! lx=
+! * (1.d0-porlocal)*lamm(lamunit,tlocal,tref,ismpl)+porlocal*fluid
+ lx = lamm(lamunit,tlocal,tref,ismpl)
+ IF (lx<=0.D0 .OR. fluid<=0.D0) THEN
+ WRITE(*,*) 'warning: "lx" computes bad math !', lx, fluid, &
+ tlocal
+ ELSE
+ lx = lx**(1.D0-porlocal)*fluid**porlocal
+ END IF
+
+ RETURN
+ END
diff --git a/props/ghe/ly.f90 b/props/ghe/ly.f90
new file mode 100644
index 0000000..ee8426b
--- /dev/null
+++ b/props/ghe/ly.f90
@@ -0,0 +1,65 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates effective thermal conductivity of the two phase
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return thermal conductivity ly[W/(m*K)]
+!> @details
+!> calculates effective thermal conductivity of the two phase\n
+!> system matrix-porosity .\n
+!> input:\n
+!> porosity porlocal [-]\n
+!> pressure plocal [pa]\n
+!> temperature tlocal in [C]\n
+ DOUBLE PRECISION FUNCTION ly(i,j,k,ismpl)
+ use arrays
+ use mod_temp
+ IMPLICIT NONE
+
+
+ INTEGER i, j, k, ui, ismpl
+ DOUBLE PRECISION plocal, tlocal, solid, fluid, lamunit, lamf, &
+ porlocal, tkelvin, lamm
+ EXTERNAL lamf, lamm
+
+
+! ploCal = pres(i,j,k,ismpl)*Pa_Conv1
+ tlocal = temp(i,j,k,ismpl)
+ fluid = lamf(i,j,k,ismpl)
+ ui = uindex(i,j,k)
+ porlocal = propunit(ui,idx_por,ismpl)
+ lamunit = propunit(ui,idx_lz,ismpl)*propunit(ui,idx_an_ly, &
+ ismpl)
+! ly=
+! & (1.d0-porlocal)*lamm(lamunit,tlocal,tref,ismpl)+porlocal*fluid
+ ly = lamm(lamunit,tlocal,tref,ismpl)
+ IF (ly<=0.D0 .OR. fluid<=0.D0) THEN
+ WRITE(*,*) 'warning: "ly" computes bad math !'
+ ELSE
+ ly = ly**(1.D0-porlocal)*fluid**porlocal
+ END IF
+
+ RETURN
+ END
diff --git a/props/ghe/lz.f90 b/props/ghe/lz.f90
new file mode 100644
index 0000000..4414512
--- /dev/null
+++ b/props/ghe/lz.f90
@@ -0,0 +1,64 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates effective thermal conductivity of the two phase
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return thermal conductivity lz[W/(m*K)]
+!> @details
+!> calculates effective thermal conductivity of the two phase\n
+!> system matrix-porosity .\n
+!> input:\n
+!> porosity porlocal [-]\n
+!> pressure plocal [pa]\n
+!> temperature tlocal in [C]\n
+ DOUBLE PRECISION FUNCTION lz(i,j,k,ismpl)
+ use arrays
+ use mod_temp
+ IMPLICIT NONE
+
+
+ INTEGER i, j, k, ui, ismpl
+ DOUBLE PRECISION plocal, tlocal, solid, fluid, lamunit, lamf, &
+ porlocal, tkelvin, lamm
+ EXTERNAL lamf, lamm
+
+
+! ploCal = pres(i,j,k,ismpl)*Pa_Conv1
+ tlocal = temp(i,j,k,ismpl)
+ fluid = lamf(i,j,k,ismpl)
+ ui = uindex(i,j,k)
+ porlocal = propunit(ui,idx_por,ismpl)
+ lamunit = propunit(ui,idx_lz,ismpl)
+! lz=
+! * (1.d0-porlocal)*lamm(lamunit,tlocal,tref,ismpl)+porlocal*fluid
+ lz = lamm(lamunit,tlocal,tref,ismpl)
+ IF (lz<=0.D0 .OR. fluid<=0.D0) THEN
+ WRITE(*,*) 'warning: "lz" computes bad math !'
+ ELSE
+ lz = lz**(1.D0-porlocal)*fluid**porlocal
+ END IF
+
+ RETURN
+ END
diff --git a/props/ghe/por.f90 b/props/ghe/por.f90
new file mode 100644
index 0000000..d4be904
--- /dev/null
+++ b/props/ghe/por.f90
@@ -0,0 +1,49 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign porosity to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return porosity porlocal [-]
+!> @details
+!> por returns the porosity [-] at node(i,j,k) from the input file.\n
+ double precision function por(i,j,k,ismpl)
+ use arrays, only: propunit, uindex, idx_por
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+
+ por = propunit(uindex(i,j,k),idx_por,ismpl)
+
+ return
+
+ end function por
diff --git a/props/ghe/props_check.f90 b/props/ghe/props_check.f90
new file mode 100644
index 0000000..8fa2c61
--- /dev/null
+++ b/props/ghe/props_check.f90
@@ -0,0 +1,63 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief check current PROPS choice
+!> @param[in] ismpl local sample index
+!> @details
+!> Check the local/current PROPS ldef_props against the PROPS choice
+!> in the input file (def_props).
+ subroutine props_check(ismpl)
+ use mod_genrlc, only: def_props
+
+ implicit none
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Local PROPS
+ character (len=10), parameter :: ldef_props = "ghe"
+
+ ! Test options of command line input
+ logical, external :: test_option
+
+ intrinsic trim
+
+
+#ifndef PROPS_ghe
+ write(*,'(3A)') 'error: this source was written for PROPS=', &
+ ldef_props, &
+ ', please correct this check in "props_check.f"!'
+ stop
+#endif
+ if ( .not. test_option('PROPS='//trim(def_props))) then
+ if (ldef_props/=def_props) then
+ write(*,'(7A)') 'Error: model file needs an executable', &
+ ' build from PROPS=', trim(def_props), &
+ ', but the current', ' consist of PROPS=', &
+ trim(ldef_props), '!'
+ stop
+ end if
+ end if
+
+ return
+
+ end subroutine props_check
diff --git a/props/ghe/props_end.f90 b/props/ghe/props_end.f90
new file mode 100644
index 0000000..9357557
--- /dev/null
+++ b/props/ghe/props_end.f90
@@ -0,0 +1,37 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief wrapper finishing property module
+!> @param[in] ismpl local sample index
+!> @details
+!> For ghe: Dummy Wrapper.
+ subroutine props_end(ismpl)
+
+ implicit none
+
+ ! Sample index
+ integer :: ismpl
+
+
+ return
+
+ end subroutine props_end
diff --git a/props/ghe/props_init.f90 b/props/ghe/props_init.f90
new file mode 100644
index 0000000..c583244
--- /dev/null
+++ b/props/ghe/props_init.f90
@@ -0,0 +1,41 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief wrapper initializing property module
+!> @param[in] ismpl local sample index
+!> @details
+!> Wrapper for calling read_props and check_props.
+ subroutine props_init(ismpl)
+
+ implicit none
+
+ ! Sample index
+ integer :: ismpl
+
+
+ CALL read_props(ismpl)
+
+ CALL check_props(ismpl)
+
+ return
+
+ end subroutine props_init
diff --git a/props/ghe/qc.f90 b/props/ghe/qc.f90
new file mode 100644
index 0000000..dc3b9e0
--- /dev/null
+++ b/props/ghe/qc.f90
@@ -0,0 +1,55 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign transport production to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] spec species index
+!> @param[in] ismpl local sample index
+!> @return transport production
+!> @details
+!> Assign transport production to cell. \n\n
+!>
+!> Hardcoded to zero, use only if you really know that you want
+!> transport production to exist.\n
+ double precision function qc(i,j,k,spec,ismpl)
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Species index
+ integer, intent (in) :: spec
+
+ ! Sample index
+ integer :: ismpl
+
+ ! No transport production
+ qc = 0.0d0
+
+ return
+
+ end function qc
diff --git a/props/ghe/qf.f90 b/props/ghe/qf.f90
new file mode 100644
index 0000000..6ed3011
--- /dev/null
+++ b/props/ghe/qf.f90
@@ -0,0 +1,50 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign flow production to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return flow production
+!> @details
+!> Assign flow production to cell. \n\n
+!>
+!> Hardcoded to zero, use only if you really know that you want
+!> flow production to exist.\n
+ double precision function qf(i,j,k,ismpl)
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ qf = 0.0d0
+
+ return
+
+ end function qf
diff --git a/props/ghe/qt.f90 b/props/ghe/qt.f90
new file mode 100644
index 0000000..16906b8
--- /dev/null
+++ b/props/ghe/qt.f90
@@ -0,0 +1,72 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign heat production to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return heat production
+ DOUBLE PRECISION FUNCTION qt(i,j,k,ismpl)
+ USE work_array_ghe
+ USE arrays
+ ! USE mod_genrl
+ ! USE mod_genrlc
+! IMPLICIT NONE
+ INTEGER i, j, k, ismpl
+ ! DOUBLE PRECISION por
+
+! vr : aCtor (1-por) ?
+! por=propunit(uindex(i,j,k),idx_por,ismpl)
+! qt = (1.d0- por)*(propunit(uindex(i,j,k),idx_q,ismpl)
+ qt = propunit(uindex(i,j,k),idx_q,ismpl)
+
+ IF (simtime(ismpl).le.Tin(mp,1)) THEN
+ mp=mp
+
+ ELSE
+ mp=mp+1
+ END IF
+! WRITE(*,*),Tin(m,1)
+
+! Anfang Schleife �ber Sonden
+ DO nl=1,nghe
+ IF (Tin(mp,2).ne.0) THEN ! An/aus
+! DO kl=k_start(nl),k_end(nl)
+ IF (i.eq.(ighe(nl)).and.(j.eq.jghe(nl)).and.((k.ge.k_start(nl)) &
+ .and.(k.le.k_end(nl)))) THEN
+ qt = -Tin(mp,3)*1000/&
+ (delx(ighe(nl))*dely(jghe(nl)))
+! ELSE
+! qt =propunit(uindex(i,j,k),idx_q,ismpl)
+ END IF
+ ! END DO
+ ELSE
+ qt=propunit(uindex(i,j,k),idx_q,ismpl)
+ END IF
+ END DO
+! Ende Schleife �ber Sonden
+
+! WRITE(*,*), 'Periode: (iper)' , mp, 'Zeit', simtime(ismpl)
+
+ RETURN
+ END
diff --git a/props/ghe/rce.f90 b/props/ghe/rce.f90
new file mode 100644
index 0000000..4811222
--- /dev/null
+++ b/props/ghe/rce.f90
@@ -0,0 +1,84 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates volumetric heat capacity of the cell
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return volumetric heat capacity
+!> @details
+!> calculates volumetric heat capacity of the system
+!> matrix-porosity [J/(K*m3)].\n
+ double precision function rhoceff(i,j,k,ismpl)
+
+ use arrays, only: temp
+ ! use mod_temp
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Local temperature [degC]
+ double precision :: tlocal
+
+ ! Local porosity [-]
+ double precision :: porlocal
+ double precision, external :: por
+
+ ! Matrix fraction in cell
+ double precision :: fm
+
+ ! Fluid fraction in cell
+ double precision :: ff
+
+ ! Heat capacity of the matrix
+ double precision, external :: rhocm
+
+ ! Heat capacity of the fluid
+ double precision, external :: rhocf
+
+
+ ! Local Temperature in degC
+ tlocal = temp(i,j,k,ismpl)
+
+ ! Local porosity
+ porlocal = por(i,j,k,ismpl)
+
+ ! Matrix fraction
+ fm = 1.D0 - porlocal
+
+ ! Fluid fraction
+ ff = porlocal
+
+ ! Heat capacity in cell, arithmetic mean
+ rhoceff = ff*rhocf(i,j,k,ismpl) + fm*rhocm(i,j,k,ismpl)
+
+ return
+
+ end function rhoceff
diff --git a/props/ghe/read_props.f90 b/props/ghe/read_props.f90
new file mode 100644
index 0000000..cb64735
--- /dev/null
+++ b/props/ghe/read_props.f90
@@ -0,0 +1,37 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief read additional user defined parameters
+!> @param[in] ismpl local sample index
+!> @details
+!> For ghe: So far no additional user defined parameters.
+ subroutine read_props(ismpl)
+
+ implicit none
+
+ ! Sample index
+ integer :: ismpl
+
+
+ return
+
+ end subroutine read_props
diff --git a/props/ghe/rhocf.f90 b/props/ghe/rhocf.f90
new file mode 100644
index 0000000..ce6d69f
--- /dev/null
+++ b/props/ghe/rhocf.f90
@@ -0,0 +1,62 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates heat capacity times density of water.
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return rhoc [W/(m*K)]
+!> @details
+!> calculates volumetric heat capacity of the fluid [J/(K*m3)].\n
+ double precision function rhocf(i,j,k,ismpl)
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Density of fluid [kg/m3]
+ double precision :: rfluid
+ double precision, external :: rhof
+
+ ! Water isobaric head capacity [J/(K*kg)]
+ double precision :: cfluid
+ double precision, external :: cpf
+
+ ! water density [kg/m**3]
+ rfluid = rhof(i,j,k,ismpl)
+
+ ! water isobaric heat capacity [J/(kg*K)]
+ cfluid = cpf(i,j,k,ismpl)
+
+ ! water volumetric heat capacity [J/(K*m3)]
+ rhocf = rfluid*cfluid
+
+ return
+
+ end function rhocf
diff --git a/props/ghe/rhocm.f90 b/props/ghe/rhocm.f90
new file mode 100644
index 0000000..68dfbb2
--- /dev/null
+++ b/props/ghe/rhocm.f90
@@ -0,0 +1,62 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates heat capacity*density of rock.
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return rhoc [W/(m*K)]
+!> @details
+!> temperature tlocal in [C]\n\n
+!>
+!> Under input file "# rhocm", the temperature variation coefficients
+!> cma1, cma2, cma3 can be set. \n
+!> Default: cma1 = 1.0d0, cma2 = cma3 = 0.0d0
+ double precision function rhocm(i,j,k,ismpl)
+ use arrays, only: temp, propunit, uindex, idx_rc
+ use mod_temp, only: cma1, cma2, cma3
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Temperature (degC)
+ double precision :: tlocal
+
+
+ ! Local Temperature in degC
+ tlocal = temp(i,j,k,ismpl)
+
+ ! Volumetric heat capacity from input file [J/(kg*m3)]
+ rhocm = propunit(uindex(i,j,k),idx_rc,ismpl)* &
+ (cma1+cma2*tlocal+cma3*tlocal*tlocal)
+
+ return
+
+ end function rhocm
diff --git a/props/ghe/rhof.f90 b/props/ghe/rhof.f90
new file mode 100644
index 0000000..0ce5604
--- /dev/null
+++ b/props/ghe/rhof.f90
@@ -0,0 +1,169 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief rhof(i,j,k,ismpl) calculates the density in (in kg/m^3) of pure water,
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return rho [kg/m^3]
+!> @details
+!> rhof(i,j,k,ismpl) calculates the density in (in kg/m^3) of pure
+!> water, given temperature (t, in degC), and pressure (p,in Pa) at
+!> node(i,j,k)\n \n
+!>
+!> Main source Zyvoloski1997: \n
+!>
+!> Zyvoloski, G.A., Robinson, B.A., Dash, Z.V., & Trease, L.L. Summary
+!> of the models and methods for the FEHM application - a
+!> finite-element heat- and mass-transfer code. United
+!> States. doi:10.2172/565545. \n \n
+!>
+!> See Section 8.4.3. of Zyvoloski1997 for an explanation of the
+!> "Rational function approximation" used in this subroutine. \n \n
+!> The approximation uses the table of coefficients in Appendix 10 of
+!> Zyvoloski1997.\n
+!>
+!> Alternative source (same text, more modern, without doi): \n
+!> https://fehm.lanl.gov/orgs/ees/fehm/pdfs/fehm_mms.pdf \n \n
+!>
+!> The table of coefficients from Zyvoloski1997 describes the physical
+!> values found in Haar1984: \n
+!>
+!> Lester Haar, John Gallagher, George Kell, NBS/NRC Steam Tables:
+!> Thermodynamic and Transport Properties and Computer Programs for
+!> Vapor and Liquid States of Water in SI Units, Hemisphere Publishing
+!> Corporation, Washington, 1984. \n \n
+!>
+!> range of validity:\n
+!> - pressures 0.001 - 110 MPa,\n
+!> - temperature 15 - 360 degC\n
+ double precision function rhof(i,j,k,ismpl)
+ use arrays, only: temp, pres
+ use mod_flow, only: pa_conv1
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Temperature (degC)
+ double precision :: tlocal
+
+ ! Pressure (MPa)
+ double precision :: plocal
+
+ ! Monomials of temperature and pressure
+ double precision :: t, t2, t3
+ double precision :: p, p2, p3, p4
+ double precision :: tp, t2p, tp2
+
+ ! Coefficients of numerator of rational function approximation
+ double precision, parameter :: Y0 = 0.10000000D+01
+ double precision, parameter :: Y1 = 0.17472599D-01
+ double precision, parameter :: Y2 = -0.20443098D-04
+ double precision, parameter :: Y3 = -0.17442012D-06
+ double precision, parameter :: Y4 = 0.49564109D-02
+ double precision, parameter :: Y5 = -0.40757664D-04
+ double precision, parameter :: Y6 = 0.50676664D-07
+ double precision, parameter :: Y7 = 0.50330978D-04
+ double precision, parameter :: Y8 = 0.33914814D-06
+ double precision, parameter :: Y9 = -0.18383009D-06
+
+ ! Coefficients of denominator of rational function approximation
+ double precision, parameter :: Z0 = 0.10009476D-02
+ double precision, parameter :: Z1 = 0.16812589D-04
+ double precision, parameter :: Z2 = -0.24582622D-07
+ double precision, parameter :: Z3 = -0.17014984D-09
+ double precision, parameter :: Z4 = 0.48841156D-05
+ double precision, parameter :: Z5 = -0.32967985D-07
+ double precision, parameter :: Z6 = 0.28619380D-10
+ double precision, parameter :: Z7 = 0.53249055D-07
+ double precision, parameter :: Z8 = 0.30456698D-09
+ double precision, parameter :: Z9 = -0.12221899D-09
+
+ ! Numerator and denominator of rational function approximation
+ double precision :: ta, tb
+
+
+ ! Local Pressure in MPa
+ plocal = pres(i,j,k,ismpl)*pa_conv1
+
+ ! Local Temperature in degC
+ tlocal = temp(i,j,k,ismpl)
+
+ ! Temperature out of bounds
+ if (tlocal > 360.0d0) then
+ write (*,*) "[E1]: Error: Temperature (",&
+ tlocal,") out of bounds (> 360 degC) at ", i,j,k
+ stop
+ end if
+ if (tlocal < 0.0d0) then
+ ! Relax table boundary of 15degC to error boundary 0degC
+ write (*,*) "[E2]: Error: Temperature (",&
+ tlocal,") out of bounds (< 0 degC) at ", i,j,k
+ stop
+ end if
+
+ ! Pressure out of bounds
+ if (plocal > 110.0d0) then
+ write (*,*) "[E3]: Error: Pressure (",&
+ plocal,") out of bounds (> 110 MPa) at ", i,j,k
+ stop
+ end if
+ if (plocal < 0.001d0) then
+ write (*,*) "[E4]: Error: Pressure (",&
+ plocal,") out of bounds (< 0.001 MPa) at ", i,j,k
+ stop
+ end if
+
+ ! Compute monomials in pressure and temperature
+ p = plocal
+ t = tlocal
+ p2 = p*p
+ p3 = p2*p
+ p4 = p3*p
+ t2 = t*t
+ t3 = t2*t
+ tp = p*t
+ tp2 = t*p2
+ t2p = t2*p
+
+ ! Numerator of rational function approximation
+ ta = Y0 + Y1*p + Y2*p2 + Y3*p3 + Y4*t + &
+ Y5*t2 + Y6*t3 + Y7*tp + Y8*tp2 + Y9*t2p
+
+ ! Denominator of rational function approximation
+ tb = Z0 + Z1*p + Z2*p2 + Z3*p3 + Z4*t + &
+ Z5*t2 + Z6*t3 + Z7*tp + Z8*tp2 + Z9*t2p
+
+ ! Water density
+ rhof = ta/tb
+
+ return
+
+ end function rhof
diff --git a/props/ghe/visf.f90 b/props/ghe/visf.f90
new file mode 100644
index 0000000..d88452d
--- /dev/null
+++ b/props/ghe/visf.f90
@@ -0,0 +1,167 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief rhof(i,j,k,ismpl) calculates the viscosity in (in Pa s) of pure water
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return visf [Pa s]
+!> @details
+!> rhof(i,j,k,ismpl) calculates the viscosity in (in Pa s) of pure water,\n
+!> given temperature (t, in C), and pressure (p,in Pa) at node(i,j,k)\n\n
+!>
+!> Main source Zyvoloski1997: \n
+!>
+!> Zyvoloski, G.A., Robinson, B.A., Dash, Z.V., & Trease, L.L. Summary
+!> of the models and methods for the FEHM application - a
+!> finite-element heat- and mass-transfer code. United
+!> States. doi:10.2172/565545. \n \n
+!>
+!> See Section 8.4.3. of Zyvoloski1997 for an explanation of the
+!> "Rational function approximation" used in this subroutine. \n \n
+!> The approximation uses the table of coefficients in Appendix 10 of
+!> Zyvoloski1997.\n
+!>
+!> Alternative source (same text, more modern, without doi): \n
+!> https://fehm.lanl.gov/orgs/ees/fehm/pdfs/fehm_mms.pdf \n \n
+!>
+!> The table of coefficients from Zyvoloski1997 describes the physical
+!> values found in Haar1984: \n
+!>
+!> Lester Haar, John Gallagher, George Kell, NBS/NRC Steam Tables:
+!> Thermodynamic and Transport Properties and Computer Programs for
+!> Vapor and Liquid States of Water in SI Units, Hemisphere Publishing
+!> Corporation, Washington, 1984. \n \n
+!>
+!> range of validity:\n
+!> - pressures 0.001 - 110 MPa,\n
+!> - temperature 15 - 360 degC\n
+ double precision function visf(i,j,k,ismpl)
+ use arrays, only: temp, pres
+ use mod_flow, only: pa_conv1
+
+ implicit none
+
+ ! Location indices
+ integer, intent (in) :: i
+ integer, intent (in) :: j
+ integer, intent (in) :: k
+
+ ! Sample index
+ integer :: ismpl
+
+ ! Temperature (degC)
+ double precision :: tlocal
+
+ ! Pressure (MPa)
+ double precision :: plocal
+
+ ! Monomials of temperature and pressure
+ double precision :: t, t2, t3
+ double precision :: p, p2, p3, p4
+ double precision :: tp, t2p, tp2
+
+ ! Coefficients of numerator of rational function approximation
+ double precision, parameter :: Y0 = 0.17409149D-02
+ double precision, parameter :: Y1 = 0.18894882D-04
+ double precision, parameter :: Y2 = -0.66439332D-07
+ double precision, parameter :: Y3 = -0.23122388D-09
+ double precision, parameter :: Y4 = -0.31534914D-05
+ double precision, parameter :: Y5 = 0.11120716D-07
+ double precision, parameter :: Y6 = -0.48576020D-10
+ double precision, parameter :: Y7 = 0.28006861D-07
+ double precision, parameter :: Y8 = 0.23225035D-09
+ double precision, parameter :: Y9 = 0.47180171D-10
+
+ ! Coefficients of denominator of rational function approximation
+ double precision, parameter :: Z0 = 0.10000000D+01
+ double precision, parameter :: Z1 = 0.10523153D-01
+ double precision, parameter :: Z2 = -0.22658391D-05
+ double precision, parameter :: Z3 = -0.31796607D-06
+ double precision, parameter :: Z4 = 0.29869141D-01
+ double precision, parameter :: Z5 = 0.21844248D-03
+ double precision, parameter :: Z6 = -0.87658855D-06
+ double precision, parameter :: Z7 = 0.41690362D-03
+ double precision, parameter :: Z8 = -0.25147022D-05
+ double precision, parameter :: Z9 = 0.22144660D-05
+
+ ! Numerator and denominator of rational function approximation
+ double precision :: ta, tb
+
+ ! Local Pressure in MPa
+ plocal = pres(i,j,k,ismpl)*pa_conv1
+
+ ! Local Temperature in degC
+ tlocal = temp(i,j,k,ismpl)
+
+ ! Temperature out of bounds
+ if (tlocal > 360.0d0) then
+ write (*,*) "[E1]: Error: Temperature (",&
+ tlocal,") out of bounds (> 360 degC) at ", i,j,k
+ stop
+ end if
+ if (tlocal < 0.0d0) then
+ ! Relax table boundary of 15degC to error boundary 0degC
+ write (*,*) "[E2]: Error: Temperature (",&
+ tlocal,") out of bounds (< 0 degC) at ", i,j,k
+ stop
+ end if
+
+ ! Pressure out of bounds
+ if (plocal > 110.0d0) then
+ write (*,*) "[E3]: Error: Pressure (",&
+ plocal,") out of bounds (> 110 MPa) at ", i,j,k
+ stop
+ end if
+ if (plocal < 0.001d0) then
+ write (*,*) "[E4]: Error: Pressure (",&
+ plocal,") out of bounds (< 0.001 MPa) at ", i,j,k
+ stop
+ end if
+
+ ! Compute monomials in pressure and temperature
+ p = plocal
+ t = tlocal
+ p2 = p*p
+ p3 = p2*p
+ p4 = p3*p
+ t2 = t*t
+ t3 = t2*t
+ tp = p*t
+ tp2 = t*p2
+ t2p = t2*p
+
+ ! Numerator of rational function approximation
+ ta = Y0 + Y1*p + Y2*p2 + Y3*p3 + Y4*t + &
+ Y5*t2 + Y6*t3 + Y7*tp + Y8*tp2 + Y9*t2p
+
+ ! Denominator of rational function approximation
+ tb = Z0 + Z1*p + Z2*p2 + Z3*p3 + Z4*t + &
+ Z5*t2 + Z6*t3 + Z7*tp + Z8*tp2 + Z9*t2p
+
+ ! Viscosity
+ visf = ta/tb
+
+ return
+
+ end function visf
diff --git a/props/ice/check_domain.f90 b/props/ice/check_domain.f90
new file mode 100644
index 0000000..7213e66
--- /dev/null
+++ b/props/ice/check_domain.f90
@@ -0,0 +1,115 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief domain of validity for module ice
+!> @param[in] ismpl local sample index
+ SUBROUTINE check_domain(ismpl)
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_conc
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k, l
+
+
+! counts the directions (thickness large enough)
+ INTEGER icountp, icountt, icountc
+! [csmin] reasonable physical value when not [cmin]
+ DOUBLE PRECISION pmin, pmax, tmin, tmax, cmin, csmin, cmax, &
+ hmin, hmax, dpmax, dtmax, dcmax, dhmax, dpmin, dtmin, dcmin, &
+ dhmin
+ PARAMETER (pmin=0.01D6,pmax=150.D6,tmin=-60.0D0,tmax=350.0, &
+ cmin=0.D0,csmin=1.D-30,cmax=1.D0)
+ INTRINSIC trim
+
+
+ icountp = 0
+ icountt = 0
+ icountc = 0
+ dpmax = pmax
+ dpmin = pmin
+ dtmax = tmax
+ dtmin = tmin
+ dcmax = cmax
+ dcmin = cmin
+
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ IF (pres(i,j,k,ismpl)<pmin) THEN
+ icountp = icountp + 1
+ dpmin = min(dpmin,pres(i,j,k,ismpl))
+ pres(i,j,k,ismpl) = pmin
+ END IF
+ IF (pres(i,j,k,ismpl)>pmax) THEN
+ icountp = icountp + 1
+ dpmax = max(dpmax,pres(i,j,k,ismpl))
+ pres(i,j,k,ismpl) = pmax
+ END IF
+ IF (temp(i,j,k,ismpl)<tmin) THEN
+ icountt = icountt + 1
+ dtmin = min(dtmin,temp(i,j,k,ismpl))
+ temp(i,j,k,ismpl) = tmin
+ END IF
+ IF (temp(i,j,k,ismpl)>tmax) THEN
+ icountt = icountt + 1
+ dtmax = max(dtmax,temp(i,j,k,ismpl))
+ temp(i,j,k,ismpl) = tmax
+ END IF
+ DO l = 1, ntrac
+ IF (conc(i,j,k,l,ismpl)<cmin) THEN
+ icountc = icountc + 1
+ dcmin = min(dcmin,conc(i,j,k,l,ismpl))
+ conc(i,j,k,l,ismpl) = cmin
+ END IF
+!aw-later if (conc(i,j,k,l,ismpl).gt.cmax) then
+!aw-later icountc = icountc +1
+!aw-later dcmax = max(dcmax, conc(i,j,k,l,ismpl))
+!aw-later conc(i,j,k,l,ismpl) = cmax
+!aw-later endif
+! use reasonable physical value [csmin]
+ IF (conc(i,j,k,l,ismpl)<csmin) THEN
+! to avoid numerically instabilities
+ conc(i,j,k,l,ismpl) = cmin
+ END IF
+ END DO
+ END DO
+ END DO
+ END DO
+
+ IF (icountp/=0) WRITE(*,'(3A,1I8,1A,1e16.7,1A,1e16.7,1A)') &
+ 'warning: pres not in domain of validity of module <', &
+ trim(def_props), '> at ', icountp, ' points (min', dpmin, &
+ ', max', dpmax, ')!'
+ IF (icountt/=0) WRITE(*,'(3A,1I8,1A,1e16.7,1A,1e16.7,1A)') &
+ 'warning: temp not in domain of validity of module <', &
+ trim(def_props), '> at ', icountt, ' points (min', dtmin, &
+ ', max', dtmax, ')!'
+ IF (icountc/=0) WRITE(*,'(3A,1I8,1A,1e16.7,1A,1e16.7,1A)') &
+ 'warning: conc not in domain of validity of module <', &
+ trim(def_props), '> at ', icountc, ' points (min', dcmin, &
+ ', max', dcmax, ')!'
+
+ RETURN
+ END
diff --git a/props/ice/compf.f90 b/props/ice/compf.f90
new file mode 100644
index 0000000..a51a2e9
--- /dev/null
+++ b/props/ice/compf.f90
@@ -0,0 +1,115 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief compf calculates compressibility of pure water
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return compressibility compf [1./Pa]
+!> @details
+!> compf calculates compressibility of pure water \n
+!> given temperature (t, in C), and pressure (p,in Pa)\n
+!> at node(plocal,tlocal).\n
+!> method: compf = 1/rhof d/dP rhof, rhof= fluid density.\n
+!> derived from the formulation given in:\n
+!> zylkovskij et al: models and methods summary for\n
+!> the fehmn application,\n
+!> ecd 22, la-ur-94-3787, los alamos nl, 1994.\n
+!> range of validity:\n
+!> pressures 0.01 - 110 MPa,\n
+!> temperature 0.001 - 350 �C and -46�C - 0�C\n
+!> input:\n
+!> pressure plocal [Pa]\n
+!> temperature tlocal in [C]\n
+ DOUBLE PRECISION FUNCTION compf(i,j,k,ismpl)
+ use arrays
+ use mod_flow
+ IMPLICIT NONE
+
+ INTEGER i, j, k, ismpl
+ DOUBLE PRECISION cf(20), bf(6)
+ DOUBLE PRECISION ta, tb, da, db, b2, rhof_loc, drhodp, t, t2, t3, &
+ tlocal, tred, p, p2, p3, p4, plocal, tp, t2p, tp2
+
+ DATA cf/0.10000000D+01, 0.17472599D-01, -0.20443098D-04, &
+ -0.17442012D-06, 0.49564109D-02, -0.40757664D-04, &
+ 0.50676664D-07, 0.50330978D-04, 0.33914814D-06, &
+ -0.18383009D-06, 0.10009476D-02, 0.16812589D-04, &
+ -0.24582622D-07, -0.17014984D-09, 0.48841156D-05, &
+ -0.32967985D-07, 0.28619380D-10, 0.53249055D-07, &
+ 0.30456698D-09, -0.12221899D-09/
+
+! new: after Speedy (1987) for T < 0 to -46 C
+ DATA bf/20.D0, 4.12D0, -1.13D0, 77.817D0, -78.143D0, 54.29D0/
+! end new
+
+ plocal = pres(i,j,k,ismpl)*pa_conv1
+ tlocal = temp(i,j,k,ismpl)
+ IF (tlocal<-45D0) tlocal = -45.D0
+
+ IF (tlocal<0.D0) THEN
+! new: after Speedy (1987) for T < 0 to -46 C
+ tred = (tlocal+273.15D0-227.15D0)/227.15D0
+ compf = bf(1)/sqrt(tred) + bf(2) + bf(3)*tred + &
+ bf(4)*tred*tred + bf(5)*tred*tred*tred + &
+ bf(6)*tred*tred*tred*tred
+ compf = compf*1.D-11
+ ELSE
+! end new
+ IF (tlocal>300.D0) tlocal = 300.D0
+
+ p = plocal
+ t = tlocal
+ p2 = p*p
+ p3 = p2*p
+ p4 = p3*p
+ t2 = t*t
+ t3 = t2*t
+ tp = p*t
+ t2p = t2*p
+ tp2 = t*p2
+
+! liquid density
+ ta = cf(1) + cf(2)*p + cf(3)*p2 + cf(4)*p3 + cf(5)*t + &
+ cf(6)*t2 + cf(7)*t3 + cf(8)*tp + cf(10)*t2p + cf(9)*tp2
+ tb = cf(11) + cf(12)*p + cf(13)*p2 + cf(14)*p3 + cf(15)*t + &
+ cf(16)*t2 + cf(17)*t3 + cf(18)*tp + cf(20)*t2p + &
+ cf(19)*tp2
+ rhof_loc = ta/tb
+
+! derivative C C2+2*C3*p+3*C4*p^2+C8*t+C10*t^2+2*C9*t*p
+ da = cf(2) + 2.D0*cf(3)*p + 3.D0*cf(4)*p2 + cf(8)*t + &
+ 2.D0*cf(9)*tp + cf(10)*t2
+! derivative C12+2*C13*p+3*C14*p^2+C18*t+C20*t^2+2*C19*t*p
+ db = cf(12) + 2.D0*cf(13)*p + 3.D0*cf(14)*p2 + cf(18)*t + &
+ 2.0*cf(19)*tp + cf(20)*t2
+
+ b2 = tb*tb
+ drhodp = (da*tb-ta*db)/b2
+! Compf=rhof_loc/drhodp
+! Compf=rhof_loc
+ compf = 1.E-6*drhodp/rhof_loc
+ END IF
+
+ RETURN
+ END
diff --git a/props/ice/compm.f90 b/props/ice/compm.f90
new file mode 100644
index 0000000..c0f72fd
--- /dev/null
+++ b/props/ice/compm.f90
@@ -0,0 +1,46 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+
+!> @brief compm calculates compressibility of rock
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!#> @return compm compressibility of rock
+!> @details
+!> compm calculates compressibility of rock\n
+!> given temperature (t, in C), and pressure (p,in Pa)\n
+!> at node(i,j,k).\n
+ DOUBLE PRECISION FUNCTION compm(i,j,k,ismpl)
+
+
+ use arrays
+ use mod_flow
+ IMPLICIT NONE
+
+ INTEGER i, j, k, ismpl
+
+ compm = propunit(uindex(i,j,k),idx_comp,ismpl)
+
+ RETURN
+ END
diff --git a/props/ice/compw.f90 b/props/ice/compw.f90
new file mode 100644
index 0000000..5434951
--- /dev/null
+++ b/props/ice/compw.f90
@@ -0,0 +1,69 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+ DOUBLE PRECISION FUNCTION compw(p,t)
+
+ IMPLICIT NONE
+
+ DOUBLE PRECISION t, p
+ DOUBLE PRECISION a, b, c, d, e, f, g
+ DOUBLE PRECISION rhow_loc
+! external rhow_loc
+ DOUBLE PRECISION a0, a1, a2, b0, b1, b2, c0, c1, c2, d0, d1, &
+ d2, e0, e1, e2, f0, f1, f2, g0, g1, g2
+ DATA a0, a1, a2, b0, b1, b2, c0, c1, c2, d0, d1, d2, e0, e1, &
+ e2, f0, f1, f2, g0, g1, g2/ + 9.99792877961606D+02, &
+ + 5.07605113140940D-04, -5.2842547816413D-10, &
+ + 5.13864847162196D-02, -3.61991396354483D-06, &
+ + 7.97204102509724D-12, -7.53557031774437D-03, &
+ + 6.37212093275576D-05, -1.66203631393248D-13, &
+ + 4.60380647957350D-05, -5.61299059722121D-10, &
+ + 1.80924436489400D-15, -2.26651454175013D-07, &
+ + 3.36874416675978D-12, -1.30352149261326D-17, &
+ + 6.14889851856743D-10, -1.06165223196756D-14, &
+ + 4.75014903737416D-20, -7.39221950969522D-13, &
+ + 1.42790422913922D-17, -7.13130230531541D-23/
+
+! liquid density
+ a = a0 + a1*p + a2*p**2
+ b = b0 + b1*p + b2*p**2
+ c = c0 + c1*p + c2*p**2
+ d = d0 + d1*p + d2*p**2
+ e = e0 + e1*p + e2*p**2
+ f = f0 + f1*p + f2*p**2
+ g = g0 + g1*p + g2*p**2
+
+ rhow_loc = a + b*t + c*t**2 + d*t**3 + e*t**4 + f*t**5 + g*t**6
+
+! liquid Compressibility
+ a = a1 + 2*a2*p
+ b = b1 + 2*b2*p
+ c = c1 + 2*c2*p
+ d = d1 + 2*d2*p
+ e = e1 + 2*e2*p
+ f = f1 + 2*f2*p
+ g = g1 + 2*g2*p
+
+ compw = (b*t+c*t**2+d*t**3+e*t**4+f*t**5+g*t**6)/rhow_loc
+
+ RETURN
+ END
diff --git a/props/ice/cpf.f90 b/props/ice/cpf.f90
new file mode 100644
index 0000000..5dc2038
--- /dev/null
+++ b/props/ice/cpf.f90
@@ -0,0 +1,113 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief cpf(i,j,k,ismpl) calculates the isobaric heat capacity in (in J/kg/K)
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return cpf [J/kg/K]
+!> @details
+!> cpf(i,j,k,ismpl) calculates the isobaric heat capacity in (in J/kg/K)\n
+!> of pure water, given temperature (t, in C), and pressure (p,in Pa)\n
+!> at node(i,j,k).\n
+!> method: c_p = d/dT E, E= fluid enthaply.\n
+!> derived from the formulation given in:\n
+!> zylkovskij et al: models and methods summary for\n
+!> the fehmn application,\n
+!> ecd 22, la-ur-94-3787, los alamos nl, 1994.\n
+!> Speedy, R.J. (1987) Thermodynamic properties of supercooled water \n
+!> at 1 atm. Journal of Physical Chemistry, 91: 3354–3358. \n
+!> range of validity:\n
+!> pressures 0.01 - 110 MPa,\n
+!> temperature 0.001 - 350 °c\n
+!> input:\n
+!> pressure plocal [Pa]\n
+!> temperature tlocal in [C]\n
+ DOUBLE PRECISION FUNCTION cpf(i,j,k,ismpl)
+ use arrays
+ use mod_flow
+ IMPLICIT NONE
+
+ INTEGER i, j, k, ismpl
+ DOUBLE PRECISION plocal, tlocal, enth, denthdt, tred, p, p1, &
+ p2, p3, p4, t, t1, t2, t3, tp, t2p, tp2, ta, tb, da, db, b2
+ DOUBLE PRECISION cf(20), bf(6)
+ DATA cf/0.25623465D-3, 0.10184405D-2, 0.22554970D-4, &
+ 0.34836663D-7, 0.41769866D-2, -0.21244879D-4, 0.25493516D-7, &
+ 0.89557885D-4, 0.10855046D-6, -0.21720560D-6, 0.10000000D+1, &
+ 0.23513278D-1, 0.48716386D-4, -0.19935046D-8, &
+ -0.50770309D-2, 0.57780287D-5, 0.90972916D-9, &
+ -0.58981537D-4, -0.12990752D-7, 0.45872518D-8/
+
+! new: after Speedy (1987) for T < 0 to -46 C
+ DATA bf/14.2D0, 25.952D0, 128.281D0, -221.405D0, 196.894D0, &
+ -64.812D0/
+! end new
+
+
+ plocal = pres(i,j,k,ismpl)*pa_conv1
+ tlocal = temp(i,j,k,ismpl)
+ IF (tlocal<-45D0) tlocal = -45.D0
+
+ IF (tlocal<0.D0) THEN
+! new: after Speedy (1987) for T < 0 to -46 C
+ tred = (tlocal+273.15D0-227.15D0)/227.15D0
+ cpf = bf(1)/sqrt(tred) + bf(2) + bf(3)*tred + &
+ bf(4)*tred*tred + bf(5)*tred*tred*tred + &
+ bf(6)*tred*tred*tred*tred
+ cpf = cpf*0.99048992406520D0*1000.D0/18.D0
+ ELSE
+! end new
+ IF (tlocal>300.D0) tlocal = 300.D0
+
+ p = plocal
+ t = tlocal
+ p2 = p*p
+ p3 = p2*p
+ p4 = p3*p
+ t2 = t*t
+ t3 = t2*t
+ tp = p*t
+ t2p = t2*p
+ tp2 = t*p2
+! enthalpy
+ ta = cf(1) + cf(2)*p + cf(3)*p2 + cf(4)*p3 + cf(5)*t + &
+ cf(6)*t2 + cf(7)*t3 + cf(8)*tp + cf(10)*t2p + cf(9)*tp2
+ tb = cf(11) + cf(12)*p + cf(13)*p2 + cf(14)*p3 + cf(15)*t + &
+ cf(16)*t2 + cf(17)*t3 + cf(18)*tp + cf(20)*t2p + &
+ cf(19)*tp2
+ enth = ta/tb
+
+! derivative
+ da = cf(5) + 2.D0*cf(6)*t + 3.D0*cf(7)*t2 + cf(8)*p + &
+ 2.D0*cf(10)*tp + cf(9)*p2
+ db = cf(15) + 2.D0*cf(16)*t + 3D0*cf(17)*t2 + cf(18)*p + &
+ 2.D0*cf(20)*tp + cf(19)*p2
+
+ b2 = tb*tb
+ denthdt = da/tb - ta*db/b2
+ cpf = denthdt*1.D6
+ END IF
+
+ RETURN
+ END
diff --git a/props/ice/cpi.f90 b/props/ice/cpi.f90
new file mode 100644
index 0000000..5dc9c56
--- /dev/null
+++ b/props/ice/cpi.f90
@@ -0,0 +1,66 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+
+!> @brief calculate ice isobaric heat capacity [J/(kg*K)]
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @details
+!> After:
+!> Ling, F. & Zhang (2004):
+!> A Numerical Modelfor surface energy balance and the thermal
+!> regime of the active layer and permafrost containing
+!> unfrozen water or brine
+!> Cold Regions Science & Technology, 38, 1-15
+!> Ling and Zhang cite Osterkamp, T. E. (1987):
+!> Freezing and Thawing of Soils and Permafrost
+!> Containing Unfrozen Water or Brine
+!> Water Resources Research, Vol. 23, No. 12, pages 2279-2285
+!> Osterkamp cites Dorsey, N. E. (1940):
+!> Properties of Ordinary Water-Substance, Reinhold, New York
+!> Dorsey cites Dickinson, H., & Osborne, N. (1915):
+!> The specific heat and heat of fusion of ice. Journal of
+!> the Washington Academy of Sciences, 5(10), 338-340.
+!>
+!> Alternative:
+!> Fukusako, S.:
+!> Thermophysical Properties of Ice, Snow,and Sea Ice
+!> International Journal of Thermophysics, 1990, 11, 353-372
+ DOUBLE PRECISION FUNCTION cpi(i,j,k,ismpl)
+
+
+ use arrays
+ IMPLICIT NONE
+
+ INTEGER i, j, k, ui, ismpl
+ DOUBLE PRECISION plocal, tlocal
+
+ tlocal = temp(i,j,k,ismpl)
+ IF (tlocal>0.D0) tlocal = 0.D0
+
+!vr (Fukosako 1990) cpi = 185.D0 + 6.89D0*(273.15D0+tlocal)
+ cpi=2110.D0+7.7D0*tlocal
+
+ RETURN
+ END
diff --git a/props/ice/disp.f90 b/props/ice/disp.f90
new file mode 100644
index 0000000..fec0e92
--- /dev/null
+++ b/props/ice/disp.f90
@@ -0,0 +1,40 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+
+!> @brief assign effective diffusivity z direction to cell
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!#> @return disp effective diffusivity z direction
+ DOUBLE PRECISION FUNCTION disp(i,j,k,ismpl)
+
+
+ use arrays
+ IMPLICIT NONE
+ INTEGER i, j, k, ismpl
+
+ disp = propunit(uindex(i,j,k),idx_df,ismpl)
+
+ RETURN
+ END
diff --git a/props/ice/ftheta.f90 b/props/ice/ftheta.f90
new file mode 100644
index 0000000..fcd83d0
--- /dev/null
+++ b/props/ice/ftheta.f90
@@ -0,0 +1,139 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates the fluid/ice partition function
+!> @param[in] tlocal = temperature
+!> @param[in] tliq = phase boundary temperature
+!> @param[in] wmushy = scaling factor for "mushy" region = Tsolidus-tliqidus
+!> @param[in] ismpl local sample index
+!> @param[out] theta = value of partition function (0<Theta<1)
+!> @param[out] dtheta = value of derivative of partition function with respect to temperature
+!#> returns the fluid/ice partition function theta and its derivative dtheta
+!> @details
+!>calculates the fluid/ice partition function used for the \n
+!>apparent heat capacity approach to phase change.\n
+ SUBROUTINE ftheta(tlocal,tliq,wmushy,theta,dtheta,ismpl)
+ use arrays
+ use ice
+ IMPLICIT NONE
+ INTEGER ismpl
+ DOUBLE PRECISION tlocal, theta, dtheta, val, tliq, wmushy
+
+ theta = 1.D0
+ dtheta = 0.D0
+
+ IF (tlocal<tliq) THEN
+ val = (tlocal-tliq)/wmushy
+! Theta=exp((-(T-Tf)/w)^2)
+ theta = exp(-val*val)
+! dTheta=-2*(T-Tf)/w^2*Theta;
+ dtheta = -2.D0*val*theta/wmushy
+! IF (theta.lt.liqmin) THEN
+! theta = liqmin
+! dtheta = 0.
+! END IF
+
+ END IF
+ RETURN
+ END
+
+
+!> @brief calculates the fluid/ice partition function used for the
+!> @param[in] tlocal = temperature
+!> @param[in] tliq = phase boundary temperature
+!> @param[in] wmushy = scaling factor for "mushy" region = tsolidus-tliqidus
+!> @param[in] ismpl local sample index
+!> @param[out] theta = value of partition function (0<Theta<1)
+!> @param[out] dtheta = value of derivative of partition function with respect to temperature
+!> @details
+!>calculates the fluid/ice partition function used for the \n
+!>apparent heat capacity approach to phase change (galushkin)\n
+ SUBROUTINE ftheta_gal(tlocal,tliq,wmushy,theta,dtheta,ismpl)
+ use arrays
+ use ice
+ IMPLICIT NONE
+ INTEGER ismpl
+ DOUBLE PRECISION solid, tlocal, tref, tlimit, km, theta, &
+ dtheta, a0, a1, a2, a3, a4, a5, a6, a7, a8, tliq, wmushy
+ DOUBLE PRECISION t, t1, t2, t3, t4, t5, t6, t7, t8
+ PARAMETER (a0=1.0D0,a1=0.60152823763179D0, &
+ a2=0.23218232347212D0,a3=0.04669792788297D0, &
+ a4=0.00535597924776D0,a5=0.00036415588418D0, &
+ a6=0.00001450956751D0,a7=0.00000031279149D0, &
+ a8=0.00000000281502D0)
+
+ theta = 1.D0
+ dtheta = 0.0
+
+ IF (tlocal<tliq) THEN
+ t1 = tlocal
+ t2 = t1*t1
+ t3 = t2*t1
+ t4 = t3*t1
+ t5 = t4*t1
+ t6 = t5*t1
+ t7 = t6*t1
+ t8 = t7*t1
+ theta = a0 + a1*t1 + a2*t2 + a3*t3 + a4*t4 + a5*t5 + a6*t6 + &
+ a7*t7 + a8*t8
+ dtheta = a1 + 2.D0*a2*t1 + 3.D0*a3*t2 + 4.D0*a4*t3 + &
+ 5.D0*a5*t4 + 6.D0*a6*t5 + 7.D0*a7*t6 + 8.D0*a8*t7
+ END IF
+ RETURN
+ END
+
+!> @brief calculates the fluid/ice partition function used for the
+!> @param[in] tlocal = temperature
+!> @param[in] tliq = phase boundary temperature
+!> @param[in] wpara = scaling factor for "mushy" region = tsolidus-tliqidus
+!> @param[in] ismpl local sample index
+!> @param[out] theta = value of partition function (0<Theta<1)
+!> @param[out] dtheta = value of derivative of partition function with respect to temperature
+!> @details
+!>calculates the fluid/ice partition function used for the \n
+!>apparent heat capacity approach to phase change (nikolsky2009)\n
+ SUBROUTINE ftheta_nik(tlocal,tliq,wpara,theta,dtheta,ismpl)
+ use arrays
+ use ice
+ IMPLICIT NONE
+ INTEGER ismpl
+ DOUBLE PRECISION solid,tlocal,tref,tlimit,km,theta,dtheta
+ DOUBLE PRECISION tliq,wpara
+
+ theta = 1.d0
+ dtheta = 0.0d0
+
+ IF (tlocal<tliq .and. wpara>=0.5d0 .and. wpara<=0.8d0) THEN
+ theta = (abs(tliq)**wpara)*(abs(tlocal)**(-wpara))
+
+!AW
+ dtheta= (abs(tliq)**wpara)* &
+ (-wpara)*abs(tlocal)**(-wpara-1.d0)
+!AW oben stehende Zwischenloesung muss mit unten stehendem Original korrigiert werden <- SIGN ist aber falsch!!!
+ WRITE(*,*) 'error: "ftheta_nik" needs to be modified!!!'
+ STOP
+!AW-original dtheta= (abs(tliq)**wpara)* &
+!AW-original (-wpara)*abs(tlocal)**(-wpara-1.d0)*sign(tlocal)
+
+ END IF
+ RETURN
+ END
diff --git a/props/ice/ice.f90 b/props/ice/ice.f90
new file mode 100644
index 0000000..02d7fdf
--- /dev/null
+++ b/props/ice/ice.f90
@@ -0,0 +1,33 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief variables for permafrost
+! icefrac
+! liq liquidus temperature in degree Celsius (above which ice is molten)
+! sol solidus temperature in degree Celsius (below which water is frozen)
+! lth latent heat of water and ice in J / kg
+!> liqmin NOT USED: minimal value of fluid/ice partition function theta i [-]
+ MODULE ice
+ DOUBLE PRECISION, ALLOCATABLE :: icefrac(:,:,:)
+ DOUBLE PRECISION, ALLOCATABLE :: liq(:,:,:), sol(:,:,:)
+ DOUBLE PRECISION lth, liqmin
+ END MODULE ice
diff --git a/props/ice/ice.inc b/props/ice/ice.inc
new file mode 100644
index 0000000..97f58f1
--- /dev/null
+++ b/props/ice/ice.inc
@@ -0,0 +1,23 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+ use ice
diff --git a/props/ice/ice_allocate.f90 b/props/ice/ice_allocate.f90
new file mode 100644
index 0000000..96319ab
--- /dev/null
+++ b/props/ice/ice_allocate.f90
@@ -0,0 +1,57 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+
+!#> @brief allocates space for variables for permafrost
+! icefrac
+! liq liquidus temperature in degree Celsius (above which ice is molten)
+! sol solidus temperature in degree Celsius (below which water is frozen)
+! i0 number of cells in x direction
+! j0 number of cells in y direction
+! k0 number of cells in z direction
+ SUBROUTINE ice_allocate
+ use ice
+ use mod_genrl
+ IMPLICIT NONE
+
+ ALLOCATE(icefrac(i0,j0,k0))
+ ALLOCATE(liq(i0,j0,k0))
+ ALLOCATE(sol(i0,j0,k0))
+
+ RETURN
+ END
+
+!#> @brief deallocates space for
+! icefrac
+! liq liquidus temperature in degree Celsius (above which ice is molten)
+! sol solidus temperature in degree Celsius (below which water is frozen)
+
+ SUBROUTINE ice_deallocate
+ use ice
+ IMPLICIT NONE
+
+ DEALLOCATE(icefrac)
+ DEALLOCATE(liq)
+ DEALLOCATE(sol)
+
+ RETURN
+ END
diff --git a/props/ice/kx.f90 b/props/ice/kx.f90
new file mode 100644
index 0000000..cf4a635
--- /dev/null
+++ b/props/ice/kx.f90
@@ -0,0 +1,63 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+
+!> @brief assign permeability in x direction to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return permeability (m^2)
+ DOUBLE PRECISION FUNCTION kx(i,j,k,ismpl)
+
+
+ use arrays
+ use ice
+ use mod_temp
+ IMPLICIT NONE
+
+ INTEGER i, j, k, ismpl
+ DOUBLE PRECISION t0, theta, dtheta, w0, tlocal, permi, ff, fi, &
+ porlocal, por
+ EXTERNAL por
+
+ tlocal = temp(i,j,k,ismpl)
+ t0 = liq(i,j,k)
+ w0 = abs(liq(i,j,k)-sol(i,j,k))/2.D0
+ CALL ftheta(tlocal,t0,w0,theta,dtheta,ismpl)
+ porlocal = por(i,j,k,ismpl)
+ ff = porlocal*theta
+ fi = porlocal - ff
+ permi = 10.D0**(-100.D0*fi/(porlocal+1.D-12))
+
+ IF (permi<1.0D-6) THEN
+
+ permi = 1.0D-6
+
+ END IF
+
+! permeff=PERM(I,J,K)*permi
+ kx = propunit(uindex(i,j,k),idx_kz,ismpl)* &
+ propunit(uindex(i,j,k),idx_an_kx,ismpl)*permi
+
+ RETURN
+ END
diff --git a/props/ice/ky.f90 b/props/ice/ky.f90
new file mode 100644
index 0000000..0f61e2e
--- /dev/null
+++ b/props/ice/ky.f90
@@ -0,0 +1,63 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+
+!> @brief assign permeability in y direction to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return permeability (m^2)
+ DOUBLE PRECISION FUNCTION ky(i,j,k,ismpl)
+
+
+ use arrays
+ use ice
+ use mod_temp
+ IMPLICIT NONE
+
+ INTEGER i, j, k, ismpl
+ DOUBLE PRECISION t0, theta, dtheta, w0, tlocal, permi, ff, fi, &
+ porlocal, por
+ EXTERNAL por
+
+ tlocal = temp(i,j,k,ismpl)
+ t0 = liq(i,j,k)
+ w0 = abs(liq(i,j,k)-sol(i,j,k))/2.D0
+ CALL ftheta(tlocal,t0,w0,theta,dtheta,ismpl)
+ porlocal = por(i,j,k,ismpl)
+ ff = porlocal*theta
+ fi = porlocal - ff
+ permi = 10.D0**(-100.D0*fi/(porlocal+1.D-12))
+
+ IF (permi<1.0D-6) THEN
+
+ permi = 1.0D-6
+
+ END IF
+
+! permeff=PERM(I,J,K)*permi
+ ky = propunit(uindex(i,j,k),idx_kz,ismpl)* &
+ propunit(uindex(i,j,k),idx_an_ky,ismpl)*permi
+
+ RETURN
+ END
diff --git a/props/ice/kz.f90 b/props/ice/kz.f90
new file mode 100644
index 0000000..7b9aa35
--- /dev/null
+++ b/props/ice/kz.f90
@@ -0,0 +1,63 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+
+!> @brief assign permeability in z direction to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return permeability (m^2)
+!> @details
+ DOUBLE PRECISION FUNCTION kz(i,j,k,ismpl)
+
+
+ use arrays
+ use ice
+ use mod_temp
+ IMPLICIT NONE
+
+ INTEGER i, j, k, ismpl
+ DOUBLE PRECISION t0, theta, dtheta, w0, tlocal, permi, ff, fi, &
+ porlocal, por
+ EXTERNAL por
+
+ tlocal = temp(i,j,k,ismpl)
+ t0 = liq(i,j,k)
+ w0 = abs(liq(i,j,k)-sol(i,j,k))/2.D0
+ CALL ftheta(tlocal,t0,w0,theta,dtheta,ismpl)
+ porlocal = por(i,j,k,ismpl)
+ ff = porlocal*theta
+ fi = porlocal - ff
+ permi = 10.D0**(-100.D0*fi/(porlocal+1.D-12))
+
+ IF (permi<1.0D-6) THEN
+
+ permi = 1.0D-6
+
+ END IF
+
+! permeff=PERM(I,J,K)*permi
+ kz = propunit(uindex(i,j,k),idx_kz,ismpl)*permi
+
+ RETURN
+ END
diff --git a/props/ice/lamf.f90 b/props/ice/lamf.f90
new file mode 100644
index 0000000..89fd5c2
--- /dev/null
+++ b/props/ice/lamf.f90
@@ -0,0 +1,62 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+
+!> @brief calculate the thermal conductivity lamf in W/(m*K) of the formation water
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return thermal conductivity lamf[W/(m*K)]
+!> @details
+!> calculate the thermal conductivity lamf in W/(m*K) of\n
+!>formation water, given temperature in C, and salinity in mass fraction\n
+!>(g/g)of NaCl. Thermal conductivity of freshwater, lamfw is calculated using\n
+!>the Phillips (1981) formulation. \n
+!> Phillips, S. L. "A technical databook for geothermal energy utilization."(1981).
+!>Range of validity: 20 to 330�C and up to 4 molal NaCl\n
+!> input:\n
+!> pressure plocal [Mpa]\n
+!> temperature tlocal in [C]\n
+ DOUBLE PRECISION FUNCTION lamf(i,j,k,ismpl)
+
+
+ use arrays
+ IMPLICIT NONE
+
+ INTEGER i, j, k, ismpl
+ DOUBLE PRECISION tlocal, tr, tr2, tr3, tr4
+
+
+ tlocal = temp(i,j,k,ismpl)
+ IF (tlocal<0.D0) tlocal = 0.D0
+ IF (tlocal>300.D0) tlocal = 300.D0
+
+ tr = (tlocal+273.15D0)/273.15D0
+ tr2 = tr*tr
+ tr3 = tr2*tr
+ tr4 = tr3*tr
+ lamf = (-0.92247D0+2.8395D0*tr-1.8007D0*tr2+0.52577D0*tr3- &
+ 0.07344D0*tr4)
+
+ RETURN
+ END
diff --git a/props/ice/lami.f90 b/props/ice/lami.f90
new file mode 100644
index 0000000..a5985fc
--- /dev/null
+++ b/props/ice/lami.f90
@@ -0,0 +1,61 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculate ice thermal conductivity [W/(m*K)]
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!#> return thermal conductivity of ice [W/(m*K)]
+!> @details
+!> Ling, F. & Zhang, T. (2004):
+!> A Numerical Modelfor surface energy balance and the thermal
+!> regime of the active layer and permafrost containing
+!> unfrozen water or brine
+!> Cold Regions Science & Technology, 38, 1-15
+!> Ling and Zhang cite Osterkamp, T. E. (1987):
+!> Freezing and Thawing of Soils and Permafrost
+!> Containing Unfrozen Water or Brine
+!> Water Resources Research, Vol. 23, No. 12, pages 2279-2285
+!> Alternative:
+!> Fukusako, S.:
+!> Thermophysical Properties of Ice, Snow,and Sea Ice
+!> International Journal of Thermophysics, 1990, 11, 353-372
+ DOUBLE PRECISION FUNCTION lami(i,j,k,ismpl)
+
+
+ use arrays
+ IMPLICIT NONE
+
+ INTEGER i, j, k, ismpl
+ DOUBLE PRECISION plocal, tlocal
+
+ tlocal = temp(i,j,k,ismpl)
+ IF (tlocal>0.D0) tlocal = 0.D0
+ lami = 0.4685D0 + 488.19D0/(tlocal+273.16D0)
+
+! vr (Fukosako1990)
+! vr lami=1.16d0*(1.91d0-8.66d-3*tlocal+2.97d-5*tlocal*tlocal);
+
+
+ RETURN
+ END
diff --git a/props/ice/lamm.f90 b/props/ice/lamm.f90
new file mode 100644
index 0000000..4b50486
--- /dev/null
+++ b/props/ice/lamm.f90
@@ -0,0 +1,54 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculate temperature dependent thermal conductivity
+!> @param[in,out] solid thermal conductivity at reference temperature given in input file [W / (m K)]
+!> @param[in,out] tlocal temperature at this sample index [degree Celsius]
+!> @param[in,out] tref reference temperature [degree Celsius]
+!> @param[in] ismpl local sample index
+!> @return thermal conductivity [W / (m K)]
+!> @details
+!> calculate temperature dependent thermal conductivity of the stony matrix\n
+!> (zoth & haenel, 1988)\n
+ DOUBLE PRECISION FUNCTION lamm(solid,tlocal,tref,ismpl)
+
+
+ IMPLICIT NONE
+
+ INTEGER ismpl
+ DOUBLE PRECISION solid, tlocal, tref, tlimit
+ DOUBLE PRECISION cddz, cddz0, cgt0, wgt, cgt
+ PARAMETER (tlimit=800.D0)
+
+ IF (tlocal>tlimit) THEN
+ lamm = 770.0D0/(350.0D0+tlocal) + 0.7D0
+ ELSE
+ cddz = 770.0D0/(350.0D0+tlocal) + 0.7D0
+ cddz0 = 770.0D0/(350.0D0+tref) + 0.7D0
+ cgt0 = solid/cddz0
+ wgt = (tlocal-tref)/(tlimit-tref)
+ cgt = cgt0 - (cgt0-1.0D0)*wgt
+ lamm = cgt*cddz
+ END IF
+
+ RETURN
+ END
diff --git a/props/ice/lx.f90 b/props/ice/lx.f90
new file mode 100644
index 0000000..5054335
--- /dev/null
+++ b/props/ice/lx.f90
@@ -0,0 +1,76 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+
+!> @brief calculates effective thermal conductivity of the two phase
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return thermal conductivity lx[W/(m*K)]
+!> @details
+!> calculates effective thermal conductivity of the two phase\n
+!> system matrix-porosity .\n
+!> input:\n
+!> porosity porlocal [-]\n
+!> pressure plocal [Mpa]\n
+!> temperature tlocal in [C]\n
+ DOUBLE PRECISION FUNCTION lx(i,j,k,ismpl)
+
+
+ use arrays
+ use ice
+ use mod_temp
+ IMPLICIT NONE
+
+
+ INTEGER i, j, k, ui, ismpl
+ DOUBLE PRECISION tlocal, lsolid, lfluid, porlocal, fm, fi, ff
+ DOUBLE PRECISION t0, theta, dtheta, w0, lice
+ DOUBLE PRECISION lamm, lamf, lami, por
+ EXTERNAL lamf, lamm, lami, por
+
+ ui = uindex(i,j,k)
+ tlocal = temp(i,j,k,ismpl)
+
+ t0 = liq(i,j,k)
+ w0 = abs(liq(i,j,k)-sol(i,j,k))/2.D0
+ CALL ftheta(tlocal,t0,w0,theta,dtheta,ismpl)
+
+ lfluid = lamf(i,j,k,ismpl)
+ lice = lami(i,j,k,ismpl)
+
+ lsolid = propunit(ui,idx_lz,ismpl)*propunit(ui,idx_an_lx,ismpl &
+ )
+ lsolid = lamm(lsolid,tlocal,tref,ismpl)
+
+ porlocal = por(i,j,k,ismpl)
+ fm = 1.D0 - porlocal
+ ff = porlocal*theta
+ fi = porlocal - ff
+
+
+
+ lx = lsolid**fm*lfluid**ff*lice**fi
+
+ RETURN
+ END
diff --git a/props/ice/ly.f90 b/props/ice/ly.f90
new file mode 100644
index 0000000..146801c
--- /dev/null
+++ b/props/ice/ly.f90
@@ -0,0 +1,75 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+
+!> @brief calculates effective thermal conductivity of the two phase
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return thermal conductivity ly[W/(m*K)]
+!> @details
+!> calculates effective thermal conductivity of the two phase\n
+!> system matrix-porosity .\n
+!> input:\n
+!> porosity porlocal [-]\n
+!> pressure plocal [Mpa]\n
+!> temperature tlocal in [C]\n
+ DOUBLE PRECISION FUNCTION ly(i,j,k,ismpl)
+
+
+ use arrays
+ use ice
+ use mod_temp
+ IMPLICIT NONE
+
+
+ INTEGER i, j, k, ui, ismpl
+ DOUBLE PRECISION tlocal, lsolid, lfluid, porlocal, fm, fi, ff
+ DOUBLE PRECISION t0, theta, dtheta, w0, lice
+ DOUBLE PRECISION lamm, lamf, lami, por
+ EXTERNAL lamf, lamm, lami, por
+
+ ui = uindex(i,j,k)
+ tlocal = temp(i,j,k,ismpl)
+
+ t0 = liq(i,j,k)
+ w0 = abs(liq(i,j,k)-sol(i,j,k))/2.D0
+ CALL ftheta(tlocal,t0,w0,theta,dtheta,ismpl)
+
+ lfluid = lamf(i,j,k,ismpl)
+ lice = lami(i,j,k,ismpl)
+
+ lsolid = propunit(ui,idx_lz,ismpl)*propunit(ui,idx_an_ly,ismpl &
+ )
+ lsolid = lamm(lsolid,tlocal,tref,ismpl)
+
+ porlocal = por(i,j,k,ismpl)
+ fm = 1.D0 - porlocal
+ ff = porlocal*theta
+ fi = porlocal - ff
+
+
+ ly = lsolid**fm*lfluid**ff*lice**fi
+
+ RETURN
+ END
diff --git a/props/ice/lz.f90 b/props/ice/lz.f90
new file mode 100644
index 0000000..bcc91f7
--- /dev/null
+++ b/props/ice/lz.f90
@@ -0,0 +1,74 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+
+!> @brief calculates effective thermal conductivity of the two phase
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return thermal conductivity lz[W/(m*K)]
+!> @details
+!> calculates effective thermal conductivity of the two phase\n
+!> system matrix-porosity .\n
+!> input:\n
+!> porosity porlocal [-]\n
+!> pressure plocal [Mpa]\n
+!> temperature tlocal in [C]\n
+ DOUBLE PRECISION FUNCTION lz(i,j,k,ismpl)
+
+
+ use arrays
+ use ice
+ use mod_temp
+ IMPLICIT NONE
+
+
+ INTEGER i, j, k, ui, ismpl
+ DOUBLE PRECISION tlocal, lsolid, lfluid, porlocal, fm, fi, ff
+ DOUBLE PRECISION t0, theta, dtheta, w0, lice
+ DOUBLE PRECISION lamm, lamf, lami, por
+ EXTERNAL lamf, lamm, lami, por
+
+ ui = uindex(i,j,k)
+ tlocal = temp(i,j,k,ismpl)
+
+ t0 = liq(i,j,k)
+ w0 = abs(liq(i,j,k)-sol(i,j,k))/2.D0
+ CALL ftheta(tlocal,t0,w0,theta,dtheta,ismpl)
+
+ lfluid = lamf(i,j,k,ismpl)
+ lice = lami(i,j,k,ismpl)
+
+ lsolid = propunit(ui,idx_lz,ismpl)
+ lsolid = lamm(lsolid,tlocal,tref,ismpl)
+
+ porlocal = por(i,j,k,ismpl)
+ fm = 1.D0 - porlocal
+ ff = porlocal*theta
+ fi = porlocal - ff
+
+
+ lz = lsolid**fm*lfluid**ff*lice**fi
+
+ RETURN
+ END
diff --git a/props/ice/por.f90 b/props/ice/por.f90
new file mode 100644
index 0000000..44fce21
--- /dev/null
+++ b/props/ice/por.f90
@@ -0,0 +1,41 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+
+!> @brief assign porosity to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return porosity porlocal [-]
+ DOUBLE PRECISION FUNCTION por(i,j,k,ismpl)
+
+
+ use arrays
+ IMPLICIT NONE
+
+ INTEGER i, j, k, ismpl
+
+ por = propunit(uindex(i,j,k),idx_por,ismpl)
+
+ RETURN
+ END
diff --git a/props/ice/props_check.f90 b/props/ice/props_check.f90
new file mode 100644
index 0000000..4218ff9
--- /dev/null
+++ b/props/ice/props_check.f90
@@ -0,0 +1,56 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+
+!> @brief check current PROPS choice
+!> @param[in] ismpl local sample index
+ SUBROUTINE props_check(ismpl)
+
+
+ use mod_genrlc
+ IMPLICIT NONE
+ INTEGER ismpl
+ character (len=10) :: ldef_props
+ PARAMETER (ldef_props='ice')
+ LOGICAL test_option
+ EXTERNAL test_option
+ INTRINSIC trim
+
+
+#ifndef PROPS_ice
+ WRITE(*,'(3A)') 'error: this source was written for PROPS=', &
+ ldef_props, &
+ ', please correct this check in "props_check.f"!'
+ STOP
+#endif
+ IF ( .NOT. test_option('PROPS='//trim(def_props))) THEN
+ IF (ldef_props/=def_props) THEN
+ WRITE(*,'(7A)') 'error: model file needs an executable', &
+ ' build from PROPS=', trim(def_props), &
+ ', but the current', ' consist of PROPS=', &
+ trim(ldef_props), '!'
+ STOP
+ END IF
+ END IF
+
+ RETURN
+ END
diff --git a/props/ice/props_init.f90 b/props/ice/props_init.f90
new file mode 100644
index 0000000..5dd532d
--- /dev/null
+++ b/props/ice/props_init.f90
@@ -0,0 +1,81 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief init routine
+!> @param[in] ismpl local sample index
+!> @details
+!> Set the following module variables \n
+!> - icefraq \n
+!> - liq liquidus temperature in degree Celsius \n
+!> - sol solidus temperature in degree Celsius \n
+!> - lth latent heat in J / kg \n
+!> - liqmin minimal value of fluid/ice partition function theta in [-] \n
+!>
+!> Use the following module variables \n
+!> - i0 number of cells in x direction \n
+!> - j0 number of cells in y direction \n
+!> - k0 number of cells in z direction \n
+ SUBROUTINE props_init(ismpl)
+ use arrays
+ use ice
+ use mod_genrl
+ use mod_time
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+
+ IF (linfos(3)>=2) WRITE(*,*) &
+ ' ... permafrost properties used'
+
+ CALL ice_allocate
+
+ CALL read_props(ismpl)
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ icefrac(i,j,k) = 0.D0
+ liq(i,j,k) = 0.D0
+ sol(i,j,k) = -2.D0
+ END DO
+ END DO
+ END DO
+
+ lth = 333600.0D0
+ liqmin = 0.03D0
+
+ CALL check_props(ismpl)
+
+ RETURN
+ END
+
+!> @brief dummy
+!> @param[in] ismpl local sample index
+!> calls ice_deallocate
+ SUBROUTINE props_end(ismpl)
+ IMPLICIT NONE
+ INTEGER ismpl
+
+ CALL ice_deallocate
+ RETURN
+ END
diff --git a/props/ice/qc.f90 b/props/ice/qc.f90
new file mode 100644
index 0000000..c7ee133
--- /dev/null
+++ b/props/ice/qc.f90
@@ -0,0 +1,39 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign transport production to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] spec species index
+!> @param[in] ismpl local sample index
+!> @return transport production
+ DOUBLE PRECISION FUNCTION qc(i,j,k,spec,ismpl)
+ use arrays
+ IMPLICIT NONE
+ INTEGER i, j, k, ismpl, spec
+
+
+ qc = 0.D0
+
+ RETURN
+ END
diff --git a/props/ice/qf.f90 b/props/ice/qf.f90
new file mode 100644
index 0000000..83b46d1
--- /dev/null
+++ b/props/ice/qf.f90
@@ -0,0 +1,38 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign flow production to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return flow production
+ DOUBLE PRECISION FUNCTION qf(i,j,k,ismpl)
+ use arrays
+ IMPLICIT NONE
+ INTEGER i, j, k, ismpl
+
+
+ qf = 0.D0
+
+ RETURN
+ END
diff --git a/props/ice/qt.f90 b/props/ice/qt.f90
new file mode 100644
index 0000000..9245a71
--- /dev/null
+++ b/props/ice/qt.f90
@@ -0,0 +1,43 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief assign heat production to cell
+!> @param[in] i grid indices
+!> @param[in] j grid indices
+!> @param[in] k grid indices
+!> @param[in] ismpl local sample index
+!> @return heat production [W / m^3]
+ DOUBLE PRECISION FUNCTION qt(i,j,k,ismpl)
+ use arrays
+ IMPLICIT NONE
+ INTEGER i, j, k, ismpl
+ DOUBLE PRECISION por
+
+
+! vr : aCtor (1-por) ?
+! por=propunit(uindex(i,j,k),idx_por,ismpl)
+! qt = (1.d0- por)*(propunit(uindex(i,j,k),idx_q,ismpl)
+
+ qt = propunit(uindex(i,j,k),idx_q,ismpl)
+
+ RETURN
+ END
diff --git a/props/ice/rce.f90 b/props/ice/rce.f90
new file mode 100644
index 0000000..b579754
--- /dev/null
+++ b/props/ice/rce.f90
@@ -0,0 +1,74 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+
+!> @brief calculates effective thermal conductivity of the two phase
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return thermal conductivity lz[W/(m*K)]
+!> @details
+!> calculates effective thermal conductivity of the two phase\n
+!> system matrix-porosity .\n
+!> input:\n
+!> porosity porlocal [-]\n
+!> pressure plocal [Mpa]\n
+!> temperature tlocal in [C]\n
+ DOUBLE PRECISION FUNCTION rhoceff(i,j,k,ismpl)
+
+
+ use arrays
+ use ice
+ use mod_temp
+ IMPLICIT NONE
+
+
+ INTEGER i, j, k, ui, ismpl
+ DOUBLE PRECISION tlocal, rcsolid, rcfluid, rcice, porlocal, &
+ fm, fi, ff
+ DOUBLE PRECISION t0, theta, dtheta, w0
+ DOUBLE PRECISION rhocm, rhocf, rhoci, por, rhoi, rhof
+ EXTERNAL rhocf, rhocm, rhoci, por, rhoi, rhof
+
+ ui = uindex(i,j,k)
+ tlocal = temp(i,j,k,ismpl)
+ t0 = liq(i,j,k)
+ w0 = abs(liq(i,j,k)-sol(i,j,k))/2.D0
+ CALL ftheta(tlocal,t0,w0,theta,dtheta,ismpl)
+
+ rcfluid = rhocf(i,j,k,ismpl)
+ rcice = rhoci(i,j,k,ismpl)
+ rcsolid = rhocm(i,j,k,ismpl)
+
+ porlocal = por(i,j,k,ismpl)
+
+ fm = 1.D0 - porlocal
+ ff = porlocal*theta
+ fi = porlocal - ff
+
+!DM Korrektur, 2008/02/21
+ rhoceff = rcsolid*fm + rcfluid*ff + rcice*fi + &
+ rhof(i,j,k,ismpl)*porlocal*lth*dtheta
+
+ RETURN
+ END
diff --git a/props/ice/read_props.f90 b/props/ice/read_props.f90
new file mode 100644
index 0000000..3da2600
--- /dev/null
+++ b/props/ice/read_props.f90
@@ -0,0 +1,86 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+
+!> @brief read user defined additionally parameter
+!> @param[in] ismpl local sample index
+ SUBROUTINE read_props(ismpl)
+
+
+ use arrays
+ use ice
+ use mod_genrl
+ use mod_genrlc
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+
+ character (len=80) :: line
+
+ INTEGER lblank
+ LOGICAL found, no_ext_link
+ EXTERNAL found, no_ext_link, lblank
+
+
+
+! PLEASE comment out the following line if you want to use the additional reading
+ RETURN
+
+! std. screen information
+ WRITE(*,*)
+ WRITE(*,*) ' reading additionally user parameter:'
+ WRITE(*,*) ' from file "', project(:lblank(project)), '"'
+! open model file
+ OPEN(79,file=project,status='old')
+! init HDF5 support, when available
+ CALL open_hdf5(' ')
+
+! --------- begin reading part ---------
+
+! !!! [liq] reading example for an existing [I0,J0,K0] array
+
+! searching for the right data part, special keyword '# liq init'
+ IF (found(79,'# liq init',line,.FALSE.)) THEN
+! check for an HDF5 entry 'liq', if available read the array [liq] from the HDF5 file
+ IF (no_ext_link(i0,j0,k0,liq,'liq',line)) THEN
+! read the values from the model file instead of the HDF5 file
+ READ(79,*) (((liq(i,j,k),i=1,i0),j=1,j0),k=1,k0)
+ END IF
+! std. screen information
+ WRITE(*,*) ' [R] : liq'
+ ELSE
+! std. screen information, when '# liq init' not found
+ WRITE(*,*) ' <D> : liq = -0.04'
+! make a default initialisation of the array [liq] with '-0.04d0'
+ CALL set_dval(i0*j0*k0,-0.04D0,liq)
+ END IF
+
+! !!! add here additionally array readings ...
+
+! --------- begin reading part ---------
+
+! finish HDF5 support
+ CALL close_hdf5()
+! close model file
+ CLOSE(79)
+ RETURN
+ END
diff --git a/props/ice/rhocf.f90 b/props/ice/rhocf.f90
new file mode 100644
index 0000000..7e05517
--- /dev/null
+++ b/props/ice/rhocf.f90
@@ -0,0 +1,53 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+
+!> @brief calculates heat capacity times density of water.
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return rhocf rhocf[J / (m^3 * K)]
+!> @details
+!> input:\n
+!> heat capacity of water cpf [J / kg / K]\n
+!> density rhof [kg/m^3]\n
+!> pressure plocal [Pa]\n
+!> temperature tlocal [C]\n
+ DOUBLE PRECISION FUNCTION rhocf(i,j,k,ismpl)
+
+
+ use arrays
+ IMPLICIT NONE
+
+ INTEGER i, j, k, ismpl
+ DOUBLE PRECISION plocal, tlocal, rfluid, cfluid, cpf, rhof
+ EXTERNAL cpf, rhof
+
+! water density [kg/m**3]
+ rfluid = rhof(i,j,k,ismpl)
+! water isobariC heat CapaCity [J/(kg*K)]
+ cfluid = cpf(i,j,k,ismpl)
+ rhocf = rfluid*cfluid
+
+ RETURN
+ END
diff --git a/props/ice/rhoci.f90 b/props/ice/rhoci.f90
new file mode 100644
index 0000000..d62a398
--- /dev/null
+++ b/props/ice/rhoci.f90
@@ -0,0 +1,50 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculates heat capacity*density of ice .
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return rhoci rc[J / (m^3 * K)]
+!> @details
+!> input:\n
+!> heat capacity of ice cpi [J / kg / K]\n
+!> density rhoi [kg/m^3]\n
+!> temperature tlocal [C]\n
+ DOUBLE PRECISION FUNCTION rhoci(i,j,k,ismpl)
+
+
+ use arrays
+ IMPLICIT NONE
+
+ INTEGER i, j, k, ismpl
+ DOUBLE PRECISION tlocal, rhoi, cpi
+ EXTERNAL rhoi, cpi
+
+ tlocal = temp(i,j,k,ismpl)
+ IF (tlocal>0.D0) tlocal = 0.D0
+
+ rhoci = rhoi(i,j,k,ismpl)*cpi(i,j,k,ismpl)
+
+ RETURN
+ END
diff --git a/props/ice/rhocm.f90 b/props/ice/rhocm.f90
new file mode 100644
index 0000000..eb16b07
--- /dev/null
+++ b/props/ice/rhocm.f90
@@ -0,0 +1,49 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+
+!> @brief calculates product of heat capacity and density of rock.
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return rhocm rc [J / (m^3 K)]
+!> @details
+!> input:\n
+!> pressure plocal [Mpa]\n
+!> temperature tlocal in [C]\n
+ DOUBLE PRECISION FUNCTION rhocm(i,j,k,ismpl)
+
+
+ use arrays
+ use mod_temp
+ IMPLICIT NONE
+
+ INTEGER i, j, k, ismpl
+ DOUBLE PRECISION plocal, tlocal
+
+ tlocal = temp(i,j,k,ismpl)
+ rhocm = propunit(uindex(i,j,k),idx_rc,ismpl)* &
+ (cma1+cma2*tlocal+cma3*tlocal*tlocal)
+
+ RETURN
+ END
diff --git a/props/ice/rhof.f90 b/props/ice/rhof.f90
new file mode 100644
index 0000000..a8e44bb
--- /dev/null
+++ b/props/ice/rhof.f90
@@ -0,0 +1,104 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief rhof(i,j,k,ismpl) calculates the density in (in kg/m^3) of pure water,
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return rhof [kg/m^3]
+!> @details
+!> rhof(i,j,k,ismpl) calculates the density in (in kg/m^3) of pure water,\n
+!> given temperature (t, in c), and pressure (p,in Mpa) at node(i,j,k)\n
+!> derived from the formulation given in:\n
+!> zylkovskij et al: models and methods summary for\n
+!> the fehmn application,\n
+!> ecd 22, la-ur-94-3787, los alamos nl, 1994.\n
+!> Speedy, R.J. (1987) Thermodynamic properties of supercooled water\n
+!> at 1 atm. Journal of Physical Chemistry, 91: 3354–3358.
+!> range of validity:\n
+!> pressures 0.01 - 110 MPa,\n
+!> temperature 15 - 350 °C\n
+!> input:\n
+!> pressure plocal [Pa]\n
+!> temperature tlocal in [C]\n
+ DOUBLE PRECISION FUNCTION rhof(i,j,k,ismpl)
+ use arrays
+ use mod_flow
+ IMPLICIT NONE
+
+ INTEGER i, j, k, ismpl
+ DOUBLE PRECISION cf(20), bf(6)
+ DOUBLE PRECISION ta, tb, tlocal, plocal, t, t2, t3, tred, p, &
+ p2, p3, p4, tp, t2p, tp2, contfac
+
+ DATA cf/0.10000000D+01, 0.17472599D-01, -0.20443098D-04, &
+ -0.17442012D-06, 0.49564109D-02, -0.40757664D-04, &
+ 0.50676664D-07, 0.50330978D-04, 0.33914814D-06, &
+ -0.18383009D-06, 0.10009476D-02, 0.16812589D-04, &
+ -0.24582622D-07, -0.17014984D-09, 0.48841156D-05, &
+ -0.32967985D-07, 0.28619380D-10, 0.53249055D-07, &
+ 0.30456698D-09, -0.12221899D-09/
+! new: after Speedy (1987) for T < 0 to -46 C (see also Grant, S. A., Physical \n
+! and Chemical Factors Affecting Contaminant Hydrology in Cold Environments, \n
+! Technical Report ERDC/CRREL TR-00-21, US Army Corps of Engineers, 2000) \n
+ DATA bf/901.5328593D0, -0.0011761652D0, 0.0038442382D0, &
+ -0.0157270761D0, 0.0744064614D0, -0.1406432653D0/
+! end new
+
+ contfac = 0.999195706402050D0
+ plocal = pres(i,j,k,ismpl)*pa_conv1
+ tlocal = temp(i,j,k,ismpl)
+ IF (tlocal<-45.D0) tlocal = -45.D0
+
+ IF (tlocal<0.D0) THEN
+! new: after Speedy (1987) for T < 0 to -46 C
+ tred = (tlocal+273.15D0-227.15D0)/227.15D0
+ rhof = contfac*bf(1)*exp(-227.15D0*(bf(3)*tred+0.5D0*bf(4)* &
+ tred*tred+0.333D0*bf(5)*tred*tred*tred+0.25D0*bf( &
+ 6)*tred*tred*tred*tred+2.D0*bf(2)*sqrt(tred)))
+ ELSE
+! end new
+ IF (tlocal>300.D0) tlocal = 300.D0
+
+ p = plocal
+ t = tlocal
+ p2 = p*p
+ p3 = p2*p
+ p4 = p3*p
+ t2 = t*t
+ t3 = t2*t
+ tp = p*t
+ t2p = t2*p
+ tp2 = t*p2
+
+! liquid density
+ ta = cf(1) + cf(2)*p + cf(3)*p2 + cf(4)*p3 + cf(5)*t + &
+ cf(6)*t2 + cf(7)*t3 + cf(8)*tp + cf(10)*t2p + cf(9)*tp2
+ tb = cf(11) + cf(12)*p + cf(13)*p2 + cf(14)*p3 + cf(15)*t + &
+ cf(16)*t2 + cf(17)*t3 + cf(18)*tp + cf(20)*t2p + &
+ cf(19)*tp2
+ rhof = ta/tb
+ END IF
+
+ RETURN
+ END
diff --git a/props/ice/rhoi.f90 b/props/ice/rhoi.f90
new file mode 100644
index 0000000..d1debe7
--- /dev/null
+++ b/props/ice/rhoi.f90
@@ -0,0 +1,50 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief calculate ice density [kg/m^3]
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @details
+!> Fukusako, S.:
+!> Thermophysical Properties of Ice, Snow,and Sea Ice
+!> International Journal of Thermophysics, 1990, 11, 353-372
+!>
+!> There should be another source.
+ DOUBLE PRECISION FUNCTION rhoi(i,j,k,ismpl)
+
+
+ use arrays
+ IMPLICIT NONE
+
+ INTEGER i, j, k, ui, ismpl
+ DOUBLE PRECISION plocal, tlocal
+
+
+ tlocal = temp(i,j,k,ismpl)
+ IF (tlocal>0.D0) tlocal = 0.D0
+
+ rhoi = 917.D0 - 0.151D0*tlocal
+
+ RETURN
+ END
diff --git a/props/ice/rhow.f90 b/props/ice/rhow.f90
new file mode 100644
index 0000000..245212c
--- /dev/null
+++ b/props/ice/rhow.f90
@@ -0,0 +1,134 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!#> @brief <description>
+!#> @param[in] p <description>
+!#> @param[in] t <description>
+!#> @param[in] ismpl local sample index
+!#> @return rho <description>
+!#> @details
+ DOUBLE PRECISION FUNCTION rhow(p,t)
+ IMPLICIT NONE
+ DOUBLE PRECISION t, p, p2, t2, t4, t6
+ DOUBLE PRECISION a, b, c, d, e, f, g
+ DOUBLE PRECISION a0, a1, a2, b0, b1, b2, c0, c1, c2, d0, d1, &
+ d2, e0, e1, e2, f0, f1, f2, g0, g1, g2
+ DATA a0, a1, a2, b0, b1, b2, c0, c1, c2, d0, d1, d2, e0, e1, &
+ e2, f0, f1, f2, g0, g1, g2/ + 9.99792877961606D+02, &
+ + 5.07605113140940D-04, -5.2842547816413D-10, &
+ + 5.13864847162196D-02, -3.61991396354483D-06, &
+ + 7.97204102509724D-12, -7.53557031774437D-03, &
+ + 6.37212093275576D-05, -1.66203631393248D-13, &
+ + 4.60380647957350D-05, -5.61299059722121D-10, &
+ + 1.80924436489400D-15, -2.26651454175013D-07, &
+ + 3.36874416675978D-12, -1.30352149261326D-17, &
+ + 6.14889851856743D-10, -1.06165223196756D-14, &
+ + 4.75014903737416D-20, -7.39221950969522D-13, &
+ + 1.42790422913922D-17, -7.13130230531541D-23/
+
+
+ p2 = p*p
+ t2 = t*t
+ t4 = t2*t2
+ t6 = t4*t2
+
+! liquid density
+ a = a0 + a1*p + a2*p2
+ b = b0 + b1*p + b2*p2
+ c = c0 + c1*p + c2*p2
+ d = d0 + d1*p + d2*p2
+ e = e0 + e1*p + e2*p2
+ f = f0 + f1*p + f2*p2
+ g = g0 + g1*p + g2*p2
+
+ rhow = a + b*t + c*t2 + d*t2*t + e*t4 + f*t4*t + g*t6
+
+ RETURN
+ END
+
+
+!#> @brief <description>
+!#> @param[in] p <description>
+!#> @param[in] t <description>
+!#> @param[in] ismpl local sample index
+!#> @return rho <description>
+!#> @details
+ DOUBLE PRECISION FUNCTION drhowdt(p,t)
+ IMPLICIT NONE
+ DOUBLE PRECISION t, p
+ DOUBLE PRECISION a0, a1, a2, b0, b1, b2, c0, c1, c2, d0, d1, &
+ d2, e0, e1, e2, f0, f1, f2, g0, g1, g2
+ DATA a0, a1, a2, b0, b1, b2, c0, c1, c2, d0, d1, d2, e0, e1, &
+ e2, f0, f1, f2, g0, g1, g2/ + 9.99792877961606D+02, &
+ + 5.07605113140940D-04, -5.2842547816413D-10, &
+ + 5.13864847162196D-02, -3.61991396354483D-06, &
+ + 7.97204102509724D-12, -7.53557031774437D-03, &
+ + 6.37212093275576D-05, -1.66203631393248D-13, &
+ + 4.60380647957350D-05, -5.61299059722121D-10, &
+ + 1.80924436489400D-15, -2.26651454175013D-07, &
+ + 3.36874416675978D-12, -1.30352149261326D-17, &
+ + 6.14889851856743D-10, -1.06165223196756D-14, &
+ + 4.75014903737416D-20, -7.39221950969522D-13, &
+ + 1.42790422913922D-17, -7.13130230531541D-23/
+
+! pure water density temperature derivative
+
+ drhowdt = b0+b1*p+t*(c0+c1*p+c2*p**2)*2d0+b2*p**2+t**2.d0*(d0+d1*p+d2*p**2)*3.d0+ &
+ t**3*(e0+e1*p+e2*p**2)*4.d0+t**4*(f0+f1*p+f2*p**2)*5.d0+ &
+ t**5*(g0+g1*p+g2*p**2)*6.d0
+
+ RETURN
+ END
+
+!#> @brief <description>
+!#> @param[in] p <description>
+!#> @param[in] t <description>
+!#> @param[in] ismpl local sample index
+!#> @return rho <description>
+!#> @details
+ DOUBLE PRECISION FUNCTION drhowdp(p,t)
+ IMPLICIT NONE
+ DOUBLE PRECISION t, p
+ DOUBLE PRECISION a0, a1, a2, b0, b1, b2, c0, c1, c2, d0, d1, &
+ d2, e0, e1, e2, f0, f1, f2, g0, g1, g2
+ DATA a0, a1, a2, b0, b1, b2, c0, c1, c2, d0, d1, d2, e0, e1, &
+ e2, f0, f1, f2, g0, g1, g2/ + 9.99792877961606D+02, &
+ + 5.07605113140940D-04, -5.2842547816413D-10, &
+ + 5.13864847162196D-02, -3.61991396354483D-06, &
+ + 7.97204102509724D-12, -7.53557031774437D-03, &
+ + 6.37212093275576D-05, -1.66203631393248D-13, &
+ + 4.60380647957350D-05, -5.61299059722121D-10, &
+ + 1.80924436489400D-15, -2.26651454175013D-07, &
+ + 3.36874416675978D-12, -1.30352149261326D-17, &
+ + 6.14889851856743D-10, -1.06165223196756D-14, &
+ + 4.75014903737416D-20, -7.39221950969522D-13, &
+ + 1.42790422913922D-17, -7.13130230531541D-23/
+
+! pure water density pressure derivative
+
+ drhowdp = b0+b1*p+t*(c0+c1*p+c2*p**2)*2d0+b2*p**2+ &
+ t**2*(d0+d1*p+d2*p**2)*3d0+t**3*(e0+e1*p+e2*p**2)*4d0+ &
+ t**4*(f0+f1*p+f2*p**2)*5d0+t**5*(g0+g1*p+g2*p**2)*6d0
+
+ RETURN
+ END
+
diff --git a/props/ice/visf.f90 b/props/ice/visf.f90
new file mode 100644
index 0000000..eb0eef7
--- /dev/null
+++ b/props/ice/visf.f90
@@ -0,0 +1,102 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief rhof(i,j,k,ismpl) calculates the viscosity in (in Pa s) of pure water,
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @param[in] ismpl local sample index
+!> @return visf [Pa s]
+!> @details
+!> rhof(i,j,k,ismpl) calculates the viscosity in (in Pa s) of pure water,\n
+!> given temperature (t, in C), and pressure (p,in Pa) at node(i,j,k)\n
+!> derived from the formulation given in:\n
+!> zylkovskij et al: models and methods summary for\n
+!> the fehmn application,\n
+!> ecd 22, la-ur-94-3787, los alamos nl, 1994.\n
+!> Speedy, R.J. (1987) Thermodynamic properties of supercooled water\n
+!> at 1 atm. Journal of Physical Chemistry, 91: 3354–3358.
+!> range of validity:\n
+!> pressures 0.01 - 110 mpa,\n
+!> temperature 15 - 350 °c and -46°c - 0°c\n
+!> input:\n
+!> pressure plocal [Pa]\n
+!> temperature tlocal in [C]\n
+ DOUBLE PRECISION FUNCTION visf(i,j,k,ismpl)
+ use arrays
+ use mod_flow
+ IMPLICIT NONE
+
+ INTEGER i, j, k, ismpl
+ DOUBLE PRECISION cf(20), bf(6)
+ DOUBLE PRECISION ta, tb, tlocal, plocal, t, t2, t3, tred, p, &
+ p2, p3, p4, tp, t2p, tp2
+
+ DATA cf/0.17409149D-02, 0.18894882D-04, -0.66439332D-07, &
+ -0.23122388D-09, -0.31534914D-05, 0.11120716D-07, &
+ -0.48576020D-10, 0.28006861D-07, 0.23225035D-09, &
+ 0.47180171D-10, 0.10000000D+01, 0.10523153D-01, &
+ -0.22658391D-05, -0.31796607D-06, 0.29869141D-01, &
+ 0.21844248D-03, -0.87658855D-06, 0.41690362D-03, &
+ -0.25147022D-05, 0.22144660D-05/
+! new: after Speedy (1987) for T < 0 to -46 C
+ DATA bf/26.312D0, -144.565D0, 1239.075D0, -8352.579D0, &
+ 31430.760, -48576.798D0/
+! end new
+
+ plocal = pres(i,j,k,ismpl)*pa_conv1
+ tlocal = temp(i,j,k,ismpl)
+ IF (tlocal<-45D0) tlocal = -45.D0
+
+ IF (tlocal<0.D0) THEN
+! tloCal = 0.d0
+! new: after Speedy (1987) for T < 0 to -46 C
+ tred = (tlocal+273.15D0-227.15D0)/227.15D0
+ visf = bf(1)/sqrt(tred) + bf(2) + bf(3)*tred + &
+ bf(4)*tred*tred + bf(5)*tred*tred*tred + &
+ bf(6)*tred*tred*tred*tred
+ visf = visf*0.001
+ ELSE
+! end new
+ IF (tlocal>300.D0) tlocal = 300.D0
+
+ p = plocal
+ t = tlocal
+ p2 = p*p
+ p3 = p2*p
+ p4 = p3*p
+ t2 = t*t
+ t3 = t2*t
+ tp = p*t
+ t2p = t2*p
+ tp2 = t*p2
+
+ ta = cf(1) + cf(2)*p + cf(3)*p2 + cf(4)*p3 + cf(5)*t + &
+ cf(6)*t2 + cf(7)*t3 + cf(8)*tp + cf(10)*t2p + cf(9)*tp2
+ tb = cf(11) + cf(12)*p + cf(13)*p2 + cf(14)*p3 + cf(15)*t + &
+ cf(16)*t2 + cf(17)*t3 + cf(18)*tp + cf(20)*t2p + &
+ cf(19)*tp2
+ visf = ta/tb
+ END IF
+
+ RETURN
+ END
diff --git a/shem_fw.f90 b/shem_fw.f90
new file mode 100644
index 0000000..f820bf1
--- /dev/null
+++ b/shem_fw.f90
@@ -0,0 +1,137 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief main program for forward simulation (only)
+!> @details
+!>
+!> **SHEMAT-Suite (Simulator for HEat and MAss Transport)** is a
+!> numerical code for computing flow, heat and species transport
+!> equations in porous media. The governing equations of the code are
+!> the groundwater flow equation, the heat transport equation and the
+!> species transport equation. \n\n
+!>
+!> SHEMAT-Suite includes parameter estimation and data assimilation
+!> approaches, both stochastic (Monte Carlo, ensemble Kalman filter)
+!> and deterministic (Bayesian inversion using automatic
+!> differentiation for calculating derivatives).\n\n
+!>
+!> Note: To be able to use input file parsing with hdf5, the
+!> hdf5-input-files have to be generated using the script:
+!> `convert_to_hdf5.py`. This script can be found in the repository
+!> `SHEMAT-Suite_Scripts` under
+!> `python/preprocessing/convert_to_hdf5.py`.
+program shem_fw
+ use arrays
+ use mod_genrl
+ use mod_genrlc
+ use mod_time
+#ifndef noHDF
+ use mod_input_file_parser_hdf5
+#endif
+ implicit none
+
+ ! Global sampling index
+ integer :: ismpl
+
+ ! Starting time of SHEMAT-Suite execution
+ double precision :: tsglobal
+
+ ! Finishing time of SHEMAT-Suite execution
+ double precision :: tfglobal
+
+ ! Runtime of SHEMAT-Suite execution
+ double precision ::ttglobal
+
+ ! Number of full minutes in runtime
+ integer :: tmins
+
+ ! Include version information from compilation
+ INCLUDE 'version.inc'
+
+ ! SHEMAT-Suite input filename read from shemade.job
+ character (len=80) :: filename
+
+
+ CALL sys_cputime(tsglobal)
+
+ ismpl = 1
+
+ write(*,*) ' '
+ write(*,*) '======================================'
+ write(*,*) version
+ write(*,*) '======================================'
+ write(*,*) ' '
+
+ open(unit = 66, file='shemade.job')
+
+ ! -----------------------------------------
+
+ ! read new input file name
+10 read(unit = 66, fmt = '(A)', end = 99999) filename
+
+ if (filename(1:1)=='!') go to 10
+ if (filename(1:1)=='%') go to 10
+ if (filename(1:1)=='#') go to 10
+
+ write(unit = *, fmt = *) ' '
+ write(unit = *, fmt = *) ' '
+ write(unit = *, fmt = *) ' *** NEW MODEL '
+
+ project = filename
+ runmode = 0
+ transient = .false.
+
+ ! reading input
+ call forward_preparation(filename, ismpl)
+
+ ! initialize
+ call forward_init(ismpl)
+
+ ! ---------
+ call forward_iter(simtime_0,max_simtime,ismpl)
+ ! ---------
+
+ ! output
+ call forward_write(-1,ismpl)
+ if (runmode > 0) call write_data(-1,ismpl)
+
+ call dealloc_arrays(ismpl)
+ call props_end(ismpl)
+ call dealloc_data(ismpl)
+
+ ! Another file to load?
+ go to 10
+
+ ! -----------------------------------------
+
+ ! finis terrae
+99999 continue
+ !
+ close(unit = 66)
+ call sys_cputime(tfglobal)
+ ttglobal = tfglobal - ttglobal
+ tmins = int(ttglobal/60.D0)
+ write(unit = *, fmt = '(1A,1I4,1A,1F5.2,1A)') ' total cpu time: ', tmins, ':', &
+ ttglobal - dble(tmins)*60.D0, ' min'
+ write(unit = *, fmt = *) 'RUN O.K.'
+ !
+end program shem_fw
diff --git a/solve/CMakeLists.txt b/solve/CMakeLists.txt
new file mode 100644
index 0000000..52d6644
--- /dev/null
+++ b/solve/CMakeLists.txt
@@ -0,0 +1,30 @@
+# MIT License
+#
+# Copyright (c) 2020 SHEMAT-Suite
+#
+# Permission is hereby granted, free of charge, to any person obtaining a copy
+# of this software and associated documentation files (the "Software"), to deal
+# in the Software without restriction, including without limitation the rights
+# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+# copies of the Software, and to permit persons to whom the Software is
+# furnished to do so, subject to the following conditions:
+#
+# The above copyright notice and this permission notice shall be included in all
+# copies or substantial portions of the Software.
+#
+# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+# SOFTWARE.
+
+file(GLOB SRC_SOLVE counter.f90 mod_blocking_size.f90 omp_bayes_solve.f90 omp_mvp2.f90 omp_sym_solve_ilu.f90 preconditioners.f90 solve_debug.f90
+ddl_du.f90 mod_OMP_TOOLS.f90 omp_damax.f90 omp_mvp.f90 omp_sym_solve_ssor.f90 prepare_solve.f90 solve.f90
+dense_solve.f90 nag_gen_solve.f90 omp_ddot.f90 OMP_TOOLS.f90 qddot.f90 solve_type.f90
+direct_solve.f90 norm_linsys2.f90 omp_gen_solve_diag.f90 par_tools.f90 reduction.f90 ssor_mvp_single.f90
+get_dnorm.f90 norm_linsys.f90 omp_gen_solve.f90 omp_preconditioners.f90 p_pos_anz.f90 set_dval.f90 test_matrix.f90
+get_norm2.f90 norm_resid.f90 omp_gen_solve_ilu.f90 omp_sym_solve_diag.f90 pre_bicgstab.f90 set_ival.f90 test_symmetry.f90
+get_norm.f90 omp_abbruch.f90 omp_gen_solve_ssor.f90 omp_sym_solve.f90 pre_cg.f90 set_lval.f90 test_zero.f90 )
+add_library(solve ${SRC_SOLVE})
diff --git a/solve/OMP_TOOLS.f90 b/solve/OMP_TOOLS.f90
new file mode 100644
index 0000000..bbcd774
--- /dev/null
+++ b/solve/OMP_TOOLS.f90
@@ -0,0 +1,52 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief OpenMP wrapper for "omp_get_thread_num"
+!> @return thread index number
+ INTEGER FUNCTION omp_get_his_thread_num()
+ IMPLICIT NONE
+ INTEGER n
+!$ integer (kind=4) :: OMP_GET_THREAD_NUM
+!$ external OMP_GET_THREAD_NUM
+
+ n = 0
+!$ N=OMP_GET_THREAD_NUM()
+ omp_get_his_thread_num = n
+
+ RETURN
+ END
+
+!> @brief OpenMP wrapper for "omp_get_num_threads"
+!> @return number of threads
+ INTEGER FUNCTION omp_get_num_of_threads()
+ IMPLICIT NONE
+ INTEGER n
+!$ integer (kind=4) :: OMP_GET_NUM_THREADS
+!$ external OMP_GET_NUM_THREADS
+
+ n = 1
+!$ N=OMP_GET_NUM_THREADS()
+!AW-TESTC$ N=OMP_GET_MAX_THREADS()
+ omp_get_num_of_threads = n
+
+ RETURN
+ END
diff --git a/solve/OMP_TOOLS.inc b/solve/OMP_TOOLS.inc
new file mode 100644
index 0000000..45bb90f
--- /dev/null
+++ b/solve/OMP_TOOLS.inc
@@ -0,0 +1,26 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+! local declaration of the two wrapper routines (OpenMP), instead of "omp.h"
+ integer OMP_GET_his_THREAD_NUM
+ integer OMP_GET_NUM_of_THREADS
+ external OMP_GET_his_THREAD_NUM,OMP_GET_NUM_of_THREADS
diff --git a/solve/counter.f90 b/solve/counter.f90
new file mode 100644
index 0000000..4329753
--- /dev/null
+++ b/solve/counter.f90
@@ -0,0 +1,54 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief initialisation of the floating point performance counter (only for benchmarking)
+ SUBROUTINE dp_init()
+ IMPLICIT NONE
+ INTEGER dp
+ COMMON /floating_points/dp
+ dp = 0
+ RETURN
+ END
+
+!> @brief increase the floating point performance counter (only for benchmarking)
+!> @param[in] n additional number of floating point operations
+ SUBROUTINE dp_count(n)
+ IMPLICIT NONE
+ INTEGER n, dp
+ COMMON /floating_points/dp
+!$OMP atomic
+ dp = dp + n
+ RETURN
+ END
+
+!> @brief write out the floating point performance (only for benchmarking)
+!> @param[in] time run time during benchmark
+ SUBROUTINE dp_comp(time)
+ IMPLICIT NONE
+ DOUBLE PRECISION time
+ INTEGER dp
+ COMMON /floating_points/dp
+ INTRINSIC dble
+ WRITE(*,'(1A,1F10.2)') ' [I] : MBytes/sec = ', &
+ dble(dp*8)/(time*1.0D6)
+ RETURN
+ END
diff --git a/solve/ddl_du.f90 b/solve/ddl_du.f90
new file mode 100644
index 0000000..466dfe4
--- /dev/null
+++ b/solve/ddl_du.f90
@@ -0,0 +1,114 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief solve of : D*[D+L]^(-1) x [b] = [b^]
+!> @param[in] N_I lengths of I-dimension of local matrix [M]
+!> @param[in] N_J lengths of J-dimension of local matrix [M]
+!> @param[in] N_K lengths of K-dimension of local matrix [M]
+!> @param[in] b vector [b]
+!> @param[in] MA diagonals of matrix [M]
+!> @param[in] MB diagonals of matrix [M]
+!> @param[in] MC diagonals of matrix [M]
+!> @param[in] MD diagonals of matrix [M]
+!> @param[out] b_hat the solution vector [b^]
+!> @details
+!> solve of : D*[D+L]^(-1) x [b] = [b^]\n
+!> with [M]=[L]+[D]+[R]\n
+ SUBROUTINE ddl(n_i,n_j,n_k,b,b_hat,ma,mb,mc,md)
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+ INTEGER n_i, n_j, n_k, i, j, k
+ DOUBLE PRECISION b(n_i,n_j,n_k), b_hat(n_i,n_j,n_k)
+ DOUBLE PRECISION ma(n_i,n_j,n_k), mb(n_i,n_j,n_k)
+ DOUBLE PRECISION mc(n_i,n_j,n_k), md(n_i,n_j,n_k)
+
+! ###################### not parallel Code !!! #########################
+! prepare [b^]
+! [b^] = D*(D+L)^(-1) * [b]
+!$OMP master
+ DO k = 1, n_k
+ DO j = 1, n_j
+ DO i = 1, n_i
+ b_hat(i,j,k) = b(i,j,k)
+ IF (i>1) b_hat(i,j,k) = b_hat(i,j,k) - &
+ mc(i,j,k)*b_hat(i-1,j,k)
+ IF (j>1) b_hat(i,j,k) = b_hat(i,j,k) - &
+ mb(i,j,k)*b_hat(i,j-1,k)
+ IF (k>1) b_hat(i,j,k) = b_hat(i,j,k) - &
+ ma(i,j,k)*b_hat(i,j,k-1)
+!AW ugly hack ...
+ IF (md(i,j,k)/=0.0D0) THEN
+ b_hat(i,j,k) = b_hat(i,j,k)/md(i,j,k)
+ END IF
+ END DO
+ END DO
+ END DO
+ DO k = 1, n_k
+ DO j = 1, n_j
+ DO i = 1, n_i
+ b_hat(i,j,k) = b_hat(i,j,k)*md(i,j,k)
+ END DO
+ END DO
+ END DO
+!$OMP end master
+! ################### above not parallel Code !!! ######################
+ RETURN
+ END
+
+!> @brief solve of : [D+U]^(-1) x [x^] = [x]
+!> @param[in] N_I lengths of I-dimension of local matrix [M]
+!> @param[in] N_J lengths of J-dimension of local matrix [M]
+!> @param[in] N_K lengths of K-dimension of local matrix [M]
+!> @param[in] x_hat vector [x^]
+!> @param[in] MD diagonals of matrix [M]
+!> @param[in] ME diagonals of matrix [M]
+!> @param[in] MF diagonals of matrix [M]
+!> @param[in] MG diagonals of matrix [M]
+!> @param[out] x the solution vector [x]
+ SUBROUTINE du(n_i,n_j,n_k,x_hat,x,md,me,mf,mg)
+ IMPLICIT NONE
+ INTEGER n_i, n_j, n_k, i, j, k
+ DOUBLE PRECISION x(n_i,n_j,n_k), x_hat(n_i,n_j,n_k)
+ DOUBLE PRECISION md(n_i,n_j,n_k), me(n_i,n_j,n_k)
+ DOUBLE PRECISION mf(n_i,n_j,n_k), mg(n_i,n_j,n_k)
+
+! ###################### not parallel Code !!! #########################
+! compute [x]
+! [x] = (D+U)^(-1) * [x^]
+ DO k = n_k, 1, -1
+ DO j = n_j, 1, -1
+ DO i = n_i, 1, -1
+ x(i,j,k) = x_hat(i,j,k)
+ IF (i<n_i) x(i,j,k) = x(i,j,k) - me(i,j,k)*x(i+1,j,k)
+ IF (j<n_j) x(i,j,k) = x(i,j,k) - mf(i,j,k)*x(i,j+1,k)
+ IF (k<n_k) x(i,j,k) = x(i,j,k) - mg(i,j,k)*x(i,j,k+1)
+!AW ugly hack ...
+ IF (md(i,j,k)/=0.0D0) THEN
+ x(i,j,k) = x(i,j,k)/md(i,j,k)
+ END IF
+ END DO
+ END DO
+ END DO
+! ################### above not parallel Code !!! ######################
+ RETURN
+ END
diff --git a/solve/dense_solve.f90 b/solve/dense_solve.f90
new file mode 100644
index 0000000..490c871
--- /dev/null
+++ b/solve/dense_solve.f90
@@ -0,0 +1,106 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief linear system solver [x]:=[A^-1]x[b], dense matrix (quadratic)
+!> @param[in] NIJK system size
+!> @param[in] NRHS number of right sides/solutions
+!> @param[in] A system matrix
+!> @param[in] B rigth side
+!> @param[out] X solution
+!#> @details
+ SUBROUTINE dense_solve(nijk,nrhs,a,b,x)
+ use mod_linfos
+ IMPLICIT NONE
+ INTEGER nijk, nrhs, isnull
+ INTEGER, ALLOCATABLE :: pivots(:)
+ DOUBLE PRECISION, ALLOCATABLE :: tmp(:), tmpm(:,:)
+ INTEGER error
+ DOUBLE PRECISION a(nijk,nijk), b(nijk,nrhs)
+ DOUBLE PRECISION x(nijk,nrhs), enough, enough2
+
+
+ IF ((8.0D0*dble(2*nijk+nijk*nijk))>2.0D9) THEN
+ WRITE(*,'(A,A,F9.4,A)') &
+ 'Error: array to large for direct dense', &
+ ' matrix solver (', 8.0D0*dble(2*nijk+nijk*nijk)/1024.0D0 &
+ **3, ' GBytes).'
+ STOP
+ END IF
+
+ ALLOCATE(pivots(nijk))
+ ALLOCATE(tmp(nijk))
+ ALLOCATE(tmpm(nijk,nijk))
+ error = 0
+ CALL set_ival(nijk,0,pivots)
+
+! right side to [X]
+ CALL dcopy(nijk*nrhs,b,1,x,1)
+! copy matrix
+ CALL dcopy(nijk*nijk,a,1,tmpm,1)
+
+! --------------------------------------------------------------
+
+! solve dense matrix
+ CALL dgesv(nijk,nrhs,a,nijk,pivots,x,nijk,error)
+
+ IF (error>0) THEN
+ WRITE(*,*) ' dense PLU: ', error, 'errors were found.'
+ ELSE IF (linfos(4)>=1) THEN
+!aw write(*,*) ' dense PLU finished.'
+ END IF
+
+ IF ((linfos(4)>=1) .AND. (nrhs==1)) THEN
+! MVP
+! [tmp]==[r]:=[A]x[x]
+ CALL dgemv('N',nijk,nijk,1.0D0,tmpm,nijk,x,1,0.0D0,tmp,1)
+
+ enough = 0.0D0
+ isnull = 0
+ enough2 = 0.0D0
+ CALL s_ddot(nijk,b,b,enough)
+ CALL test_zero(enough,1,isnull)
+ IF (isnull/=1) THEN
+ CALL s_ddot(nijk,tmp,tmp,enough2)
+ enough2 = abs(enough-enough2)/(enough)
+ END IF
+
+! [r]:=[w]-[A]x[x]
+ CALL dscal(nijk,-1.0D0,tmp,1)
+ CALL daxpy(nijk,1.0D0,b,1,tmp,1)
+
+ enough = 0.0D0
+ CALL s_ddot(nijk,tmp,tmp,enough)
+ WRITE(*,'(2(a,e12.5))') ' PLU: nrm2(R)', dsqrt(enough), &
+ ' rel=', enough2
+ END IF
+
+! restore matrix (only needed for debug)
+ CALL dcopy(nijk*nijk,tmpm,1,a,1)
+
+ DEALLOCATE(pivots)
+ DEALLOCATE(tmp)
+ DEALLOCATE(tmpm)
+
+! --------------------------------------------------------------
+
+ RETURN
+ END
diff --git a/solve/direct_solve.f90 b/solve/direct_solve.f90
new file mode 100644
index 0000000..6c46cf9
--- /dev/null
+++ b/solve/direct_solve.f90
@@ -0,0 +1,165 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief direct linear solver call: PLU from LAPACK, solve of : [M] x [x] = [b]
+!> @param[in] I0 lengths of I-dimension of local matrix [M]
+!> @param[in] J0 lengths of J-dimension of local matrix [M]
+!> @param[in] K0 lengths of K-dimension of local matrix [M]
+!> @param[out] x solution vector [x]
+!> @param[in] w right side, vector [b]
+!> @param[in] A 1. diagonal of the system matrix [M]
+!> @param[in] B 2. diagonal of the system matrix [M]
+!> @param[in] C 3. diagonal of the system matrix [M]
+!> @param[in] D 4. diagonal of the system matrix [M]
+!> @param[in] E 5. diagonal of the system matrix [M]
+!> @param[in] F 6. diagonal of the system matrix [M]
+!> @param[in] G 7. diagonal of the system matrix [M]
+ SUBROUTINE direct_solve(i0,j0,k0,x,w,a,b,c,d,e,f,g)
+ use mod_linfos
+ IMPLICIT NONE
+
+ INTEGER i0, j0, k0, kl, ku, ldm
+
+ DOUBLE PRECISION, ALLOCATABLE :: matrix(:,:)
+ INTEGER, ALLOCATABLE :: pivots(:)
+ INTEGER error, i, j, k, ind, nijk
+
+! need to detect 64Bit enviroment
+ INTEGER test32
+ INTEGER (kind=8) test64
+
+ DOUBLE PRECISION x(i0,j0,k0), w(i0,j0,k0), enough, enough2
+ DOUBLE PRECISION a(i0,j0,k0), b(i0,j0,k0), c(i0,j0,k0), &
+ d(i0,j0,k0), e(i0,j0,k0), f(i0,j0,k0), g(i0,j0,k0)
+
+
+ nijk = i0*j0*k0
+ kl = i0*j0
+ IF (i0==1) kl = i0*j0
+ IF (j0==1) kl = i0*j0
+ IF (k0==1) kl = i0
+ ku = kl
+ ldm = 2*kl + ku + 1
+
+! detecting 64Bit-Integer enviroment (t32=t64 for 64Bit)
+ test32 = 3000000
+ test64 = 3000000
+ test32 = test32*test32
+ test64 = test64*test64
+
+! protecting against 32 pointers
+ IF ((8.0D0*dble(ldm)*dble(nijk))>2.0D9) THEN
+ IF (test32==test64) THEN
+ WRITE(*,'(A,A)') 'Warning: try to use 64Bit integer', &
+ ' enviroment (needs 64Bit system)'
+ ELSE
+ WRITE(*,'(A,A,F9.4,A)') &
+ 'Error: array to large for direct band', &
+ ' matrix solver (', 8.0D0*dble(ldm)*dble(nijk)/1024.0D0 &
+ **3, ' GBytes).'
+ STOP
+ END IF
+ END IF
+
+ ALLOCATE(matrix(ldm,nijk))
+ ALLOCATE(pivots(nijk))
+ error = 0
+
+! right side to [X]
+ CALL dcopy(nijk,w,1,x,1)
+ CALL set_dval(ldm*nijk,0.D0,matrix)
+
+! --------------------------------------------------------------
+
+ ind = 0
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+!aw ind=i +I0*(j-1) +I0*J0*(k-1)
+ ind = ind + 1
+! if (i<20 .and. j==1 .and. k==1) write(*,*) "d(",i,",",j,",",k,")=",d(i,j,k)
+ IF (d(i,j,k)==0.0D0) THEN
+ WRITE(*,'(A,3I5,A,2e15.8)') &
+ 'error in direct_solve.f90: main diagonal element equal to zero at ', i, &
+ j, k, '=', d(i,j,k)
+ STOP
+ ELSE
+! copy diagonals into band strukture
+ matrix(ldm-kl,ind) = d(i,j,k)
+ IF (ind>1 .AND. i0>1) matrix(ldm-kl+1,ind-1) = c(i,j, &
+ k)
+ IF (ind<=nijk-1 .AND. i0>1) matrix(ldm-kl-1,ind+1) &
+ = e(i,j,k)
+
+ IF (ind>i0 .AND. j0>1) matrix(ldm-kl+i0,ind-i0) = b(i, &
+ j,k)
+ IF (ind<=nijk-i0 .AND. j0>1) matrix(ldm-kl-i0,ind+i0) &
+ = f(i,j,k)
+
+ IF (ind>i0*j0 .AND. k0>1) matrix(ldm-kl+i0*j0, &
+ ind-i0*j0) = a(i,j,k)
+ IF (ind<=nijk-i0*j0 .AND. k0>1) matrix(ldm-kl-i0*j0, &
+ ind+i0*j0) = g(i,j,k)
+ END IF
+
+ END DO
+ END DO
+ END DO
+
+!aw call dgesv(NIJK,1,matrix,NIJK,pivots,X,NIJK,error)
+ CALL dgbsv(nijk,kl,ku,1,matrix,ldm,pivots,x,nijk,error)
+
+! --------------------------------------------------------------
+
+ IF ((linfos(4)>=2) .OR. (error>0)) THEN
+ WRITE(*,*) ' PLU: ', error, 'errors was found.'
+ END IF
+
+! print latest, "matrix" is used as tmp. vector
+ IF (linfos(4)>=1) THEN
+! MVP
+! [r=matrix]:=[A]x[x]
+ CALL s_mvp(i0,j0,k0,x,matrix,a,b,c,d,e,f,g)
+! [r]:=[w]-[A]x[x]
+ CALL dscal(nijk,-1.0D0,matrix,1)
+ CALL daxpy(nijk,1.0D0,w,1,matrix,1)
+
+! Ueberpruefung, ob Abbruch
+ enough = 0.0D0
+ enough2 = 0.0D0
+
+ CALL s_damax(nijk,matrix,enough)
+ CALL s_ddot(nijk,matrix,matrix,enough2)
+ IF (linfos(4)>=2) THEN
+ WRITE(*,'(2(1a,1d20.13))') ' damax(R) =', enough, &
+ ', nrm2(R)', dsqrt(enough2)
+ ELSE
+ WRITE(*,'(1a,1d20.13,1a)') ' nrm2(R) =', dsqrt(enough2), &
+ ' (direct)'
+ END IF
+ END IF
+
+ DEALLOCATE(matrix)
+ DEALLOCATE(pivots)
+
+ RETURN
+ END
diff --git a/solve/get_dnorm.f90 b/solve/get_dnorm.f90
new file mode 100644
index 0000000..8b4cc36
--- /dev/null
+++ b/solve/get_dnorm.f90
@@ -0,0 +1,57 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief return modified diagonal prepared for normalisation
+!> @param[in] md diagonal (system matrix)
+!> @param[in] mbc_mask boundary mask
+!> @param[in] N number of elements, vector length
+!> @param[out] dnrm normalisation vector
+ SUBROUTINE get_dnorm(n,mbc_mask,md,dnrm)
+ IMPLICIT NONE
+ INTEGER n, i
+ DOUBLE PRECISION dnrm(n), dcrit_nrm
+! diagonal (system matrix)
+ DOUBLE PRECISION md(n)
+! boundary mask
+ CHARACTER mbc_mask(n)
+ INTRINSIC dsqrt, dabs, dble
+ LOGICAL test_null
+ EXTERNAL test_null
+
+! correction for 2-Norm
+ dcrit_nrm = dsqrt(dble(n))
+
+ DO i = 1, n
+ dnrm(i) = 0.D0
+! add, since it is no boundary condition element
+ IF (mbc_mask(i)=='+') THEN
+ IF (test_null(md(i))) THEN
+ WRITE(*,*) 'zero at ', i, md(i), mbc_mask(i)
+ END IF
+! important: diagonal dominance
+! used for adaptive scaling the residuum
+ dnrm(i) = 1.D0/dabs(md(i)*dcrit_nrm)
+ END IF
+ END DO
+!
+ RETURN
+ END
diff --git a/solve/get_norm.f90 b/solve/get_norm.f90
new file mode 100644
index 0000000..e309552
--- /dev/null
+++ b/solve/get_norm.f90
@@ -0,0 +1,59 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief return normalisation-vector for initial normalisation of the linear-system
+!> @param[in] mw right side, solution, diagonal (system matrix)
+!> @param[in] mbc_mask boundary mask
+!> @param[in] N number of elements, vector length
+!> @param[in] md diagonal of the system matrx
+!> @param[in] mx currentr solution vector (used for step by step updates)
+!> @param[out] dnormalise updated (new) normalisation vector
+ SUBROUTINE get_norm(n,mw,mbc_mask,md,mx,dnormalise)
+ IMPLICIT NONE
+ INTEGER n, i
+ DOUBLE PRECISION dnormalise(n), dcrit_nrm
+! right side, solution, diagonal (system matrix)
+ DOUBLE PRECISION mw(n), mx(n), md(n)
+! boundary mask
+ CHARACTER mbc_mask(n)
+ INTRINSIC dsqrt, dabs, dble
+ LOGICAL test_null
+ EXTERNAL test_null
+
+! correction for 2-Norm
+ dcrit_nrm = dsqrt(dble(n))
+
+ DO i = 1, n
+ dnormalise(i) = 1.D0
+! add, since it is no boundary condition element
+ IF (mbc_mask(i)=='+') THEN
+! important: diagonal dominance
+ IF ( .NOT. test_null(mx(i))) THEN
+ dnormalise(i) = 1.D0/dabs(md(i)*mx(i)*dcrit_nrm)
+ ELSE
+ dnormalise(i) = 1.D0/(max(dabs(md(i)),dabs(mw(i)))*dcrit_nrm)
+ END IF
+ END IF
+ END DO
+!
+ RETURN
+ END
diff --git a/solve/get_norm2.f90 b/solve/get_norm2.f90
new file mode 100644
index 0000000..e246d4e
--- /dev/null
+++ b/solve/get_norm2.f90
@@ -0,0 +1,60 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief return normalisation-vector for initial normalisation of the linear-system
+!> @param[in] mw right side, solution, diagonal (system matrix)
+!> @param[in] mbc_mask boundary mask
+!> @param[in] N number of elements, vector length
+!> @param[in] md diagonal of the system matrx
+!> @param[in] mx currentr solution vector (used for step by step updates)
+!> @param[out] dnormalise updated (new) normalisation vector
+!> @param[in] soddmx second offset (dominant) diagonal*mx
+ SUBROUTINE get_norm2(n,mw,mbc_mask,md,mx,dnormalise,soddmx)
+ IMPLICIT NONE
+ INTEGER n, i
+ DOUBLE PRECISION dnormalise(n), dcrit_nrm
+! right side, solution, diagonal (system matrix)
+ DOUBLE PRECISION mw(n), mx(n), md(n), soddmx(n)
+! boundary mask
+ CHARACTER mbc_mask(n)
+ INTRINSIC dsqrt, dabs, dble
+ LOGICAL test_null
+ EXTERNAL test_null
+
+! correction for 2-Norm
+ dcrit_nrm = dsqrt(dble(n))
+
+ DO i = 1, n
+ dnormalise(i) = 1.D0
+! add, since it is no boundary condition element
+ IF (mbc_mask(i)=='+') THEN
+! important: diagonal dominance
+ IF ( .NOT. test_null(mx(i))) THEN
+ dnormalise(i) = 1.D0 /(max(dabs(md(i)*mx(i)), soddmx(i))*dcrit_nrm)
+ ELSE
+ dnormalise(i) = 1.D0 /(max(dabs(md(i)), dabs(mw(i)), soddmx(i))*dcrit_nrm)
+ END IF
+ END IF
+ END DO
+!
+ RETURN
+ END
diff --git a/solve/mod_OMP_TOOLS.f90 b/solve/mod_OMP_TOOLS.f90
new file mode 100644
index 0000000..3479e14
--- /dev/null
+++ b/solve/mod_OMP_TOOLS.f90
@@ -0,0 +1,27 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief thread level information
+module mod_OMP_TOOLS
+! number of threads for level 0(outer region) and 1(inner region)
+ integer Tlevel_0, Tlevel_1
+end module mod_OMP_TOOLS
diff --git a/solve/mod_blocking_size.f90 b/solve/mod_blocking_size.f90
new file mode 100644
index 0000000..207e513
--- /dev/null
+++ b/solve/mod_blocking_size.f90
@@ -0,0 +1,43 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief solver constants and prozessor cache & block size information
+module mod_blocking_size
+! processor-cache size, cache-block size
+ integer cache_size, bl_size
+!
+ integer block_i, block_j, block_k
+ integer bdim_i, bdim_j, bdim_k
+ integer max_blocks
+!
+! chunk size optimisation (for different cases)
+ double precision bldiv_cg
+ double precision bldiv_bicg(2)
+ double precision bldiv_mvp
+ double precision bldiv_dot(3)
+!
+! maximal number of temporary vectors needed in a linear system solver
+! 1..9: "pre_CG" system solver
+! 1..13: "pre_BiCGStab" system solver
+ integer max_locTMP
+ parameter (max_locTMP = 13)
+end module mod_blocking_size
diff --git a/solve/norm_linsys.f90 b/solve/norm_linsys.f90
new file mode 100644
index 0000000..2be9e30
--- /dev/null
+++ b/solve/norm_linsys.f90
@@ -0,0 +1,83 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief normalise the linear system, matrix and the right side
+!> @param[in] N size of all given vectors
+!> @param[in] mbc_mask boundary mask
+!> @param[in,out] mw right side, solution
+!> @param[in] mx [x]-vector
+!> @param[in,out] MA 1. diagonal of the system matrix
+!> @param[in,out] MB 2. diagonal of the system matrix
+!> @param[in,out] MC 3. diagonal of the system matrix
+!> @param[in,out] MD 4. diagonal of the system matrix
+!> @param[in,out] ME 5. diagonal of the system matrix
+!> @param[in,out] MF 6. diagonal of the system matrix
+!> @param[in,out] MG 7. diagonal of the system matrix
+!> @param[out] dnormalise normalising vector for adaptive resiuum
+ SUBROUTINE norm_linsys(n,mbc_mask,mw,mx,ma,mb,mc,md,me,mf,mg,dnormalise)
+ IMPLICIT NONE
+ INTEGER n, i
+! normalising value
+ DOUBLE PRECISION dnormalise(n)
+! matrix coefficients
+ DOUBLE PRECISION ma(n), mb(n), mc(n), md(n), me(n), mf(n), &
+ mg(n)
+! right side, solution
+ DOUBLE PRECISION mw(n), mx(n)
+ CHARACTER mbc_mask(n)
+
+
+! get the norm.-vector for initial normalisation of the system
+ CALL get_norm(n,mw,mbc_mask,md,mx,dnormalise)
+
+! normalise the system matrix
+ DO i = 1, n
+ ma(i) = ma(i)*dnormalise(i)
+ END DO
+ DO i = 1, n
+ mb(i) = mb(i)*dnormalise(i)
+ END DO
+ DO i = 1, n
+ mc(i) = mc(i)*dnormalise(i)
+ END DO
+ DO i = 1, n
+ md(i) = md(i)*dnormalise(i)
+ END DO
+ DO i = 1, n
+ me(i) = me(i)*dnormalise(i)
+ END DO
+ DO i = 1, n
+ mf(i) = mf(i)*dnormalise(i)
+ END DO
+ DO i = 1, n
+ mg(i) = mg(i)*dnormalise(i)
+ END DO
+! normalise the right side
+ DO i = 1, n
+ mw(i) = mw(i)*dnormalise(i)
+ END DO
+
+! get the prepared/updated normalisation vector
+ CALL get_dnorm(n,mbc_mask,md,dnormalise)
+
+ RETURN
+ END
diff --git a/solve/norm_linsys2.f90 b/solve/norm_linsys2.f90
new file mode 100644
index 0000000..e173262
--- /dev/null
+++ b/solve/norm_linsys2.f90
@@ -0,0 +1,84 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief normalise the linear system, matrix and the right side
+!> @param[in] N size of all given vectors
+!> @param[in] mbc_mask boundary mask
+!> @param[in,out] mw right side, solution
+!> @param[in] mx [x]-vector
+!> @param[in,out] MA 1. diagonal of the system matrix
+!> @param[in,out] MB 2. diagonal of the system matrix
+!> @param[in,out] MC 3. diagonal of the system matrix
+!> @param[in,out] MD 4. diagonal of the system matrix
+!> @param[in,out] ME 5. diagonal of the system matrix
+!> @param[in,out] MF 6. diagonal of the system matrix
+!> @param[in,out] MG 7. diagonal of the system matrix
+!> @param[in,out] dnormalise normalising vector for adaptive resiuum (disabled function - working on matnormalise), as input initialised with second offset (dominant) diagonal*x
+!> @param[out] matnormalise normalising vector for matrix system
+ SUBROUTINE norm_linsys2(n,mbc_mask,mw,mx,ma,mb,mc,md,me,mf,mg,dnormalise,matnormalise)
+ IMPLICIT NONE
+ INTEGER n, i
+! normalising value
+ DOUBLE PRECISION dnormalise(n), matnormalise(n)
+! matrix coefficients
+ DOUBLE PRECISION ma(n), mb(n), mc(n), md(n), me(n), mf(n), &
+ mg(n)
+! right side, solution
+ DOUBLE PRECISION mw(n), mx(n)
+ CHARACTER mbc_mask(n)
+
+
+! get the norm.-vector for the normalisation of the system (in "matnormalise")
+ CALL get_norm2(n,mw,mbc_mask,md,mx,matnormalise,dnormalise)
+
+! normalise the system matrix
+ DO i = 1, n
+ ma(i) = ma(i)*matnormalise(i)
+ END DO
+ DO i = 1, n
+ mb(i) = mb(i)*matnormalise(i)
+ END DO
+ DO i = 1, n
+ mc(i) = mc(i)*matnormalise(i)
+ END DO
+ DO i = 1, n
+ md(i) = md(i)*matnormalise(i)
+ END DO
+ DO i = 1, n
+ me(i) = me(i)*matnormalise(i)
+ END DO
+ DO i = 1, n
+ mf(i) = mf(i)*matnormalise(i)
+ END DO
+ DO i = 1, n
+ mg(i) = mg(i)*matnormalise(i)
+ END DO
+! normalise the right side
+ DO i = 1, n
+ mw(i) = mw(i)*matnormalise(i)
+ END DO
+
+! disable the adaptive normalisation (normalisation vector = 0)
+ CALL set_dval(n,0.0d0,dnormalise)
+
+ RETURN
+ END
diff --git a/solve/norm_resid.f90 b/solve/norm_resid.f90
new file mode 100644
index 0000000..1476575
--- /dev/null
+++ b/solve/norm_resid.f90
@@ -0,0 +1,46 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief adaptive update normalisation of the residuum
+!> @param[in] N vector length
+!> @param[in] dnrm main part of the normalisation vector
+!> @param[in] xval current result vector, needed for normalisation
+!> @param[out] rval update vector
+ SUBROUTINE norm_resid(n,dnrm,xval,rval)
+ IMPLICIT NONE
+ INTEGER n, i
+ DOUBLE PRECISION dtmp, dnrm(n), xval(n), rval(n)
+ LOGICAL test_null
+ EXTERNAL test_null
+ INTRINSIC dabs
+
+ DO i = 1, n
+ IF ( .NOT. test_null(dnrm(i))) THEN
+ IF ( .NOT. test_null(xval(i))) THEN
+ dtmp = dnrm(i)/dabs(xval(i))
+ rval(i) = rval(i)*dtmp
+ END IF
+ END IF
+ END DO
+!
+ RETURN
+ END
diff --git a/solve/omp_abbruch.f90 b/solve/omp_abbruch.f90
new file mode 100644
index 0000000..b9fad73
--- /dev/null
+++ b/solve/omp_abbruch.f90
@@ -0,0 +1,277 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief probe for break criteria, (OpenMP version)
+!> @param[in] enough value for ||[res]|| or max(abs(res)), see 'criteria'
+!> @param[in] iter count iterations
+!> @param[in] max_It maximum of iterations, counted with 'iter'
+!> @param[in] depsilon precision criteria to break iterations
+!> @param[in] need_Ax switch to compute an extra MVP:([A]x[x]) in [ax], see 'criteria'
+!> @param[in] criteria switch to set when should break\n
+!> - 0 : relative stopping crit. : ||[res]|| < depsilon*||[res0]||\n
+!> - 1 : absolute stopping crit. : ||[res]|| < depsilon\n
+!> - 2 : maximum stopping crit. : max(abs([res])) < depsilon\n
+!> - 3 : abs. and rel. stopping crit. : ( ||[res]|| < depsilon ) and ( ||[res]|| < 0.5d0*||[res0]|| )\n
+!> 0.5d0 is a constant for testing only and is named 'minRel'\n
+!> first [res] ^= [r_0] and later (if precise enough) : [res] ^= ([A]x[x]-[b])
+!> @param[in] res0 res0 ^= ||[res0]||, should be start residue
+!> @param[in] divide_zero (>0) division by zero ?
+!> @param[in,out] e_count counts the number of reaching the criteria
+!> @param[in,out] e_old last good `enough` value
+!> @return false : continue (not enough precision), true : break - enough precision or max_It reached
+ LOGICAL FUNCTION omp_abbruch(enough,iter,max_it,depsilon, &
+ need_ax,criteria,res0,divide_zero,e_count,e_old)
+ use mod_OMP_TOOLS
+ use mod_linfos
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+! break with enough precision
+ DOUBLE PRECISION depsilon, enough
+ DOUBLE PRECISION res0, e_old
+ INTEGER e_count
+! see above
+ DOUBLE PRECISION minrel
+ PARAMETER (minrel=0.99D0)
+! need_Ax : switch to compute an extra MVP:([A]x[x]) in [ax]
+! criteria : switch to break
+ LOGICAL need_ax, flag_abbruch
+ INTEGER criteria
+ character (len=3) :: rstr
+! iter : count iterations,
+! max_It : max iterations,
+! divide_zero <> 0 : break should be done too
+ INTEGER iter, max_it, divide_zero
+ INTRINSIC dsqrt
+
+
+ rstr = '[r]'
+ IF (need_ax) rstr = '(R)'
+
+! default -> break iterations
+ flag_abbruch = .TRUE.
+
+! max-iterations reached ?
+ IF (iter>max_it) GO TO 100
+
+! same result the last three times ?
+ IF ((e_count>3) .AND. (e_old==enough)) THEN
+!$OMP master
+ IF (linfos(4)>=1) WRITE(*,*) &
+ ' Warning : stopping before precision reached'
+!$OMP end master
+ GO TO 100
+ END IF
+
+! enough precision ?
+
+ IF (criteria==1) THEN
+! absolute
+! write(*,*) "Testing absolute ",enough,"<=",depsilon*depsilon,"?"
+ IF (enough<=(depsilon*depsilon)) THEN
+ IF (need_ax) GO TO 100
+ need_ax = .TRUE.
+ END IF
+ ELSE IF (criteria==2) THEN
+! maximum
+! write(*,*) "Testing maximum ",enough,"<=",depsilon,"?"
+ IF (enough<=depsilon) THEN
+ IF (need_ax) GO TO 100
+ need_ax = .TRUE.
+ END IF
+ ELSE IF (criteria==3) THEN
+! absolute and relative
+! write(*,*) "Testing absolut and relative ",enough,"<=",res0*res0*minrel*minrel," and",depsilon*depsilon,"?"
+ IF ((enough<=(res0*res0*minrel*minrel)) .AND. (enough<=( &
+ depsilon*depsilon))) THEN
+ IF (need_ax) GO TO 100
+ need_ax = .TRUE.
+ END IF
+ ELSE IF (criteria==0) THEN
+! relative
+! write(*,*) "Testing relative ",enough,"<=",depsilon*res0*depsilon*res0
+ IF (enough<=(depsilon*res0*depsilon*res0)) THEN
+ IF (need_ax) GO TO 100
+ need_ax = .TRUE.
+ END IF
+ END IF
+
+! continue, no break
+ IF (divide_zero==0) flag_abbruch = .FALSE.
+
+ IF (e_old==enough) THEN
+ e_count = e_count + 1
+ ELSE
+ e_old = enough
+ e_count = 0
+ END IF
+
+! stop label
+100 CONTINUE
+
+333 FORMAT (3A,1D20.13,1A)
+!$OMP master
+! print latest
+ IF ((linfos(4)>=1) .AND. (flag_abbruch)) THEN
+ IF (criteria==2) THEN
+ WRITE(*,333,advance='NO') ' damax', rstr, ' =', enough, &
+ ' '
+ ELSE
+ WRITE(*,333,advance='NO') ' nrm2', rstr, ' =', &
+ dsqrt(enough), ' '
+ END IF
+ ELSE IF (linfos(4)>=3 .AND. linfos(4)/=100) THEN
+ IF (criteria==2) THEN
+ WRITE(*,333,advance='NO') ' damax', rstr, ' =', enough, &
+ ','
+ ELSE
+ WRITE(*,333,advance='NO') ' nrm2', rstr, ' =', &
+ dsqrt(enough), ','
+ END IF
+ END IF
+!$OMP end master
+
+ omp_abbruch = flag_abbruch
+ RETURN
+ END
+
+!> @brief probe for break criteria, serial (no OpenMP) implementation of "omp_abbruch", see above
+!> @param[in] enough value for ||[res]|| or max(abs(res)), see 'criteria'
+!> @param[in] iter count iterations
+!> @param[in] max_It maximum of iterations, counted with 'iter'
+!> @param[in] depsilon precision criteria to break iterations
+!> @param[in] need_Ax switch to compute an extra MVP:([A]x[x]) in [ax], see 'criteria'
+!> @param[in] criteria switch to set when should break\n
+!> - 0 : relative stopping crit. : ||[res]|| < depsilon*||[res0]||\n
+!> - 1 : absolute stopping crit. : ||[res]|| < depsilon\n
+!> - 2 : maximum stopping crit. : max(abs([res])) < depsilon\n
+!> - 3 : abs. and rel. stopping crit. : ( ||[res]|| < depsilon ) and ( ||[res]|| < 0.5d0*||[res0]|| )\n
+!> 0.5d0 is a constant for testing only and is named 'minRel'\n
+!> first [res] ^= [r_0] and later (if precise enough) : [res] ^= ([A]x[x]-[b])
+!> @param[in] res0 res0 ^= ||[res0]||, should be start residue
+!> @param[in] divide_zero (>0) division by zero ?
+!> @param[in,out] e_count counts the number of reaching the criteria
+!> @param[in,out] e_old last good `enough` value
+!> @return false : continue (not enough precision), true : break - enough precision or max_It reached
+ LOGICAL FUNCTION s_abbruch(enough,iter,max_it,depsilon,need_ax, &
+ criteria,res0,divide_zero,e_count,e_old)
+ use mod_linfos
+ IMPLICIT NONE
+! break with enough precision
+ DOUBLE PRECISION depsilon, enough
+ DOUBLE PRECISION res0, e_old
+ INTEGER e_count
+! see above
+ DOUBLE PRECISION minrel
+ PARAMETER (minrel=0.99D0)
+! need_Ax : switch to compute an extra MVP:([A]x[x]) in [ax]
+! criteria : switch to break
+ LOGICAL need_ax, flag_abbruch
+ INTEGER criteria
+ character (len=3) :: rstr
+! iter : count iterations,
+! max_It : max iterations,
+! divide_zero <> 0 : break should be done too
+ INTEGER iter, max_it, divide_zero
+ INTRINSIC dsqrt
+
+
+ rstr = '[r]'
+ IF (need_ax) rstr = '(R)'
+
+! default -> break iterations
+ flag_abbruch = .TRUE.
+
+! max-iterations reached ?
+ IF (iter>max_it) GO TO 100
+
+! same result the last three times ?
+ IF ((e_count>3) .AND. (e_old==enough)) THEN
+ IF (linfos(4)>=1) WRITE(*,*) &
+ ' Warning : stopping before precision reached'
+ GO TO 100
+ END IF
+
+! enough precision ?
+
+ IF (criteria==1) THEN
+! absolute
+ IF (enough<=(depsilon*depsilon)) THEN
+ IF (need_ax) GO TO 100
+ need_ax = .TRUE.
+ END IF
+ ELSE IF (criteria==2) THEN
+! maximum
+ IF (enough<=depsilon) THEN
+ IF (need_ax) GO TO 100
+ need_ax = .TRUE.
+ END IF
+ ELSE IF (criteria==3) THEN
+! absolute and relative
+ IF ((enough<=(res0*res0*minrel*minrel)) .AND. (enough<=( &
+ depsilon*depsilon))) THEN
+ IF (need_ax) GO TO 100
+ need_ax = .TRUE.
+ END IF
+ ELSE IF (criteria==0) THEN
+! relative
+ IF (enough<=(depsilon*res0*depsilon*res0)) THEN
+ IF (need_ax) GO TO 100
+ need_ax = .TRUE.
+ END IF
+ END IF
+
+! continue, no break
+ IF (divide_zero==0) flag_abbruch = .FALSE.
+
+ IF (e_old==enough) THEN
+ e_count = e_count + 1
+ ELSE
+ e_old = enough
+ e_count = 0
+ END IF
+
+! stop label
+100 CONTINUE
+
+333 FORMAT (3A,1D20.13,1A)
+! print latest
+ IF ((linfos(4)>=1) .AND. (flag_abbruch)) THEN
+ IF (criteria==2) THEN
+ WRITE(*,333,advance='NO') ' damax', rstr, ' =', enough, &
+ ' '
+ ELSE
+ WRITE(*,333,advance='NO') ' nrm2', rstr, ' =', &
+ dsqrt(enough), ' '
+ END IF
+ ELSE IF (linfos(4)>=3 .AND. linfos(4)/=100) THEN
+ IF (criteria==2) THEN
+ WRITE(*,333,advance='NO') ' damax', rstr, ' =', enough, &
+ ','
+ ELSE
+ WRITE(*,333,advance='NO') ' nrm2', rstr, ' =', &
+ dsqrt(enough), ','
+ END IF
+ END IF
+
+ s_abbruch = flag_abbruch
+ RETURN
+ END
diff --git a/solve/omp_bayes_solve.f90 b/solve/omp_bayes_solve.f90
new file mode 100644
index 0000000..b2ce255
--- /dev/null
+++ b/solve/omp_bayes_solve.f90
@@ -0,0 +1,190 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief solve of : [Bayes] x [x] = [b], BICGSTAB algorithm based
+!> @param[in] N dimension of the matrix [Bayes]
+!> @param[in,out] x solution vector [x], on start = start vector
+!> @param[in] b right side, vector [b]
+!> @param[in] r0_hat random vector [r0_hat] ^= [r0^]
+!> @param[in] depsilon precision criteria to break iterations
+!> @param[in] max_It max iteration number
+!> @param[in] criteria precision criteria mode to break iterations\n
+!> - 0 : relative stopping crit.: ||[res]|| < depsilon*||[res0]||\n
+!> - 1 : absolute stopping crit.: ||[res]|| < depsilon\n
+!> - 2 : maximum stopping crit.: max(abs([res])) < depsilon\n
+!> first [res]^=[r], later (if precise enough): [res]^=([M]x[x]-[b])
+!> @param[out] locTMP local temporary vectors
+!> @param[out] DATTMP additional data temporary vectors
+!> @param[in,out] dnrm normalisation vector, temporary use
+!> @param[in] ismpl local sample index
+!> @details
+!> solve of : [Bayes] x [x] = [b]\n
+!> [Bayes] is a indirect defined Matrix\n
+!> Technics :\n
+!> - use reverse communication technics.\n
+!> each vector should be dense full without any hole,\n
+!> ( you can copy your elements from your structure to a \n
+!> temporary dense full vector, befor you use this algorithm \n
+!> and give the correct number of elements in 'N' ).\n
+!> if you have setup all vectors by a specific composition,\n
+!> each vector (x,b,r,...) on the same thread should use\n
+!> the same composition (same structure for all vectors on\n
+!> one thread).\n
+ SUBROUTINE omp_bayes_solve(N,x,b,r0_hat,depsilon,max_it,criteria,loctmp,dattmp,dnrm,ismpl)
+ use mod_OMP_TOOLS
+ use mod_blocking_size
+ use mod_linfos
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+! N : length of all vector r,z,s,t,v,p,y,t_pc,s_pc
+ INTEGER N, max_it, ismpl
+! thread stuff
+ INTEGER tpos, tanz
+! vector x and b for [M]x[x]=[b]
+! res0 ^= ||res0||, start residuel, given for 'criteria=0'
+ DOUBLE PRECISION x(N), b(N)
+ DOUBLE PRECISION r0_hat(N), res0
+! definitions of 'work' and 'locTMP'
+ INCLUDE 'pre_bicgstab.inc'
+! locTMP : space for local vectors, using to exchange data with
+! 'matrix-vector-product'(MVP) and 'pre-conditioners'(L/R),
+! for definitions see more in 'pre_bicgstab.inc'
+ DOUBLE PRECISION loctmp(N,max_loctmp)
+ DOUBLE PRECISION dattmp(*), dnrm(N)
+! Pre_BiCGStab stuff
+! work : control variable : what is to do in this subroutine,
+! see more discription in 'pre_bicgstab.inc',
+! on startup should set to 'work=START'
+ INTEGER work
+! break with enough precision
+ DOUBLE PRECISION depsilon
+!
+ INTEGER criteria, linfos_old
+ INTEGER l, wieviele
+ DOUBLE PRECISION dmaxi, dmini, durchs
+! openmp-shared variables
+ INTEGER ipar(5), iii
+ DOUBLE PRECISION, ALLOCATABLE :: rpar(:)
+ LOGICAL lpar(1)
+
+!
+! full number of elements
+ res0 = 1.D+99
+
+!**************************************************************
+
+! start values
+ work = start
+
+!$OMP parallel &
+!$OMP num_threads(Tlevel_0)&
+!$OMP default(shared)&
+!$OMP private(tanz,tpos,iii,linfos_old)
+!$ call omp_binding(ismpl)
+
+ CALL omp_part(n,tpos,tanz)
+
+!$OMP master
+ iii = 5 + 4*omp_get_num_of_threads()
+ ALLOCATE(rpar(iii))
+ CALL set_dval(iii,0.D0,rpar)
+!$OMP end master
+ linfos_old = linfos(4)
+!$OMP barrier
+
+! preload ([M]x[x]) in [z]
+!$OMP master
+ CALL step_bayes_tmpm(x,dattmp,loctmp(1,z),ismpl)
+!$OMP end master
+!$OMP barrier
+
+! Reverse communication loop for bicgstab
+10 CONTINUE
+
+
+! BiCGStab routine
+ linfos(4) = 1
+ CALL pre_bicgstab(tanz,x(tpos),b(tpos),r0_hat(tpos),n, &
+ loctmp(tpos,1),depsilon,dnrm(tpos),max_it,criteria,res0, &
+ work,ipar,rpar,lpar)
+! implicite barrier here
+ linfos(4) = linfos_old
+!$OMP barrier
+
+! preconditioner [y]:=[K^-1]x[p],
+! matrix-vector product [v]:=[M]x[y]
+ IF ((work==do_y_p_v) .OR. (work==more_y_p_v)) THEN
+! left precond.
+ CALL myprco(n,loctmp(1,p),loctmp(1,t_pc))
+! right precond.
+ CALL myprco(n,loctmp(1,t_pc),loctmp(1,y))
+!$OMP barrier
+
+!$OMP master
+ CALL step_bayes_tmpm(loctmp(1,y),dattmp,loctmp(1,v),ismpl)
+!$OMP end master
+!$OMP barrier
+ END IF
+
+! [z]:=[M]x[x], for advanced precision
+ IF (work==more_y_p_v) THEN
+!$OMP master
+ CALL step_bayes_tmpm(x,dattmp,loctmp(1,z),ismpl)
+!$OMP end master
+!$OMP barrier
+ END IF
+
+! preconditioner [z]:=[K^-1]x[s],
+! preconditioner [s_pc]:=[L_K^-1]x[s],
+! matrix-vector product [t]:=[M]x[z],
+! preconditioner [t_pc]:=[L_K^-1]x[t]
+ IF (work==do_z_s_t) THEN
+! left precond.
+ CALL myprco(n,loctmp(1,s),loctmp(1,s_pc))
+! right precond.
+ CALL myprco(n,loctmp(1,s_pc),loctmp(1,z))
+!$OMP barrier
+
+!$OMP master
+ CALL step_bayes_tmpm(loctmp(1,z),dattmp,loctmp(1,t),ismpl)
+!$OMP end master
+!$OMP barrier
+
+! left precond.
+ CALL myprco(n,loctmp(1,t),loctmp(1,t_pc))
+!$OMP barrier
+ END IF
+
+
+! precision not enough ?
+ IF ((work/=fine) .AND. (work/=abort)) GO TO 10
+! at "work=ABORT", we can startup with a new [r^]
+
+!$OMP end parallel
+
+ DEALLOCATE(rpar)
+
+!**************************************************************
+
+
+ RETURN
+ END
diff --git a/solve/omp_damax.f90 b/solve/omp_damax.f90
new file mode 100644
index 0000000..8a1c701
--- /dev/null
+++ b/solve/omp_damax.f90
@@ -0,0 +1,83 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief computes the maximum of vector [x] and broadcast to all, (OpenMP version)
+!> @param[in] N length of vector [x]
+!> @param[in] X vector [x]
+!> @param[in] sh_max openmp-shared help variable
+!> @param[out] MAX_X maximum of [x]
+ SUBROUTINE omp_damax(n,x,max_x,sh_max)
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+! N : length of vector [x]
+! ind : index of maximal element
+ INTEGER n, i, ind
+! vector [x]
+ DOUBLE PRECISION x(n), sh_max, max_x
+ INTEGER idamax
+ EXTERNAL idamax
+ INTRINSIC dabs
+
+! orphaning feature needed
+!$OMP master
+! clear before compute
+ sh_max = 0.0D0
+!$OMP end master
+!$OMP barrier
+!
+! very simple (slow) variation
+!$OMP do schedule(static) reduction(max:sh_max)
+ DO i = 1, omp_get_num_of_threads()
+! compute local maximum
+ ind = idamax(n,x,1)
+ IF (ind>=1 .AND. n>=1) sh_max = max(sh_max,dabs(x(ind)))
+ END DO
+!$OMP end do
+! barrier here ...
+!
+ max_x = sh_max
+ RETURN
+ END
+
+!> @brief computes the maximum of vector [x], serial (no OpenMP) implementation, see above
+!> @param[in] N length of vector [x]
+!> @param[in] X vector [x]
+!> @param[out] MAX_X maximum of [x]
+ SUBROUTINE s_damax(n,x,max_x)
+ IMPLICIT NONE
+! N : length of vector [x]
+! ind : index of maximal element
+ INTEGER n, ind
+! vector [x]
+ DOUBLE PRECISION x(n), max_x
+ INTEGER idamax
+ EXTERNAL idamax
+ INTRINSIC dabs
+
+! very simple (slow) variation
+! compute local maximum
+ max_x = 0.0D0
+ ind = idamax(n,x,1)
+ IF (ind>=1 .AND. n>=1) max_x = dabs(x(ind))
+ RETURN
+ END
diff --git a/solve/omp_ddot.f90 b/solve/omp_ddot.f90
new file mode 100644
index 0000000..3f6ce23
--- /dev/null
+++ b/solve/omp_ddot.f90
@@ -0,0 +1,259 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief compute ([x]^T*[y]) distributed and build a global sum, (OpenMP version)
+!> @param[in] N length of all vectors
+!> @param[in] X vector [x]
+!> @param[in] Y vector [y]
+!> @param[in] sh_help openmp-shared vector [# threads *1]
+!> @param[out] S solution ( [x]^T*[y] )
+ SUBROUTINE omp_ddot(n,x,y,s,sh_help)
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+! N : length of all vector x,y
+ INTEGER n
+! lsum : local-summary
+! lsum : source summary
+! vectors [x], [y]
+ DOUBLE PRECISION lsum(1), slsum(1), x(n), y(n), s, sh_help(*)
+ DOUBLE PRECISION qddot
+ EXTERNAL qddot
+ DOUBLE PRECISION ddot
+ EXTERNAL ddot
+
+! compute local-sum
+#ifdef USE_QDDOT
+ lsum(1) = qddot(n,x,1,y,1)
+#else
+ lsum(1) = ddot(n,x,1,y,1)
+#endif
+! compute global sum (OpenMP)
+ CALL xsum_0(1,lsum,slsum,sh_help)
+ s = slsum(1)
+ RETURN
+ END
+
+!> @brief compute ([x]^T*[y]) and build the sum, serial (no OpenMP) implementation
+!> @param[in] N length of all vectors
+!> @param[in] X vector [x]
+!> @param[in] Y vector [y]
+!> @param[out] S solution ( [x]^T*[y] )
+ SUBROUTINE s_ddot(n,x,y,s)
+ IMPLICIT NONE
+! N : length of all vector x,y
+ INTEGER n
+! vectors [x], [y]
+ DOUBLE PRECISION x(n), y(n), s
+ DOUBLE PRECISION qddot
+ EXTERNAL qddot
+ DOUBLE PRECISION ddot
+ EXTERNAL ddot
+
+! compute local-sum
+#ifdef USE_QDDOT
+ s = qddot(n,x,1,y,1)
+#else
+ s = ddot(n,x,1,y,1)
+#endif
+ RETURN
+ END
+
+!> @brief 2x compute ([x]^T*[y]) distributed and build a global sum, (OpenMP version)
+!> @param[in] N length of all vectors
+!> @param[in] X vector [x]
+!> @param[in] X2 vector [x]
+!> @param[in] Y vector [y]
+!> @param[in] Y2 vector [y]
+!> @param[in] sh_help openmp-shared vector [# threads *2]
+!> @param[out] S solution ( [x]^T*[y] )
+!> @param[out] S2 solution ( [x]^T*[y] )
+!> @details
+!> Function : compute ([x]^T*[y]) distributed and build a global sum,\n
+!> 2 products at once\n
+ SUBROUTINE omp_2ddot(n,x,y,s,x2,y2,s2,sh_help)
+ use mod_OMP_TOOLS
+ use mod_blocking_size
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+! N : length of all vector x,y
+ INTEGER n
+! lsum : local-summary
+! lsum : source summary
+! vectors [x], [y]
+ DOUBLE PRECISION lsum(2), slsum(2), sh_help(*)
+ DOUBLE PRECISION x(max(n,1)), y(max(n,1)), s
+ DOUBLE PRECISION x2(max(n,1)), y2(max(n,1)), s2
+ INTEGER von, bis
+ DOUBLE PRECISION qddot
+ EXTERNAL qddot
+ DOUBLE PRECISION ddot
+ EXTERNAL ddot
+
+ lsum(1) = 0.0D0
+ lsum(2) = 0.0D0
+! blocking
+ DO von = 1, n, int(bl_size/bldiv_dot(1))
+ bis = min(n,von+int(bl_size/bldiv_dot(1))-1)
+! compute local-sum
+#ifdef USE_QDDOT
+ lsum(1) = lsum(1) + qddot(bis-von+1,x(von),1,y(von),1)
+ lsum(2) = lsum(2) + qddot(bis-von+1,x2(von),1,y2(von),1)
+#else
+ lsum(1) = lsum(1) + ddot(bis-von+1,x(von),1,y(von),1)
+ lsum(2) = lsum(2) + ddot(bis-von+1,x2(von),1,y2(von),1)
+#endif
+ END DO
+! compute global sum (OpenMP)
+ CALL xsum_0(2,lsum,slsum,sh_help)
+ s = slsum(1)
+ s2 = slsum(2)
+ RETURN
+ END
+
+!> @brief 3x compute ([x]^T*[y]) distributed and build a global sum, (OpenMP version)
+!> @param[in] N length of all vectors
+!> @param[in] X vector [x]
+!> @param[in] X2 vector [x]
+!> @param[in] X3 vector [x]
+!> @param[in] Y vector [y]
+!> @param[in] Y2 vector [y]
+!> @param[in] Y3 vector [y]
+!> @param[in] sh_help openmp-shared vector [# threads *3]
+!> @param[out] S solution ( [x]^T*[y] )
+!> @param[out] S2 solution ( [x]^T*[y] )
+!> @param[out] S3 solution ( [x]^T*[y] )
+!> @details
+!> Function : compute ([x]^T*[y]) distributed and build a global sum,\n
+!> 3 products at once\n
+ SUBROUTINE omp_3ddot(n,x,y,s,x2,y2,s2,x3,y3,s3,sh_help)
+ use mod_OMP_TOOLS
+ use mod_blocking_size
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+! N : length of all vector x,y
+ INTEGER n
+! lsum : local-summary
+! lsum : source summary
+! vectors [x], [y]
+ DOUBLE PRECISION lsum(3), slsum(3), sh_help(*)
+ DOUBLE PRECISION x(max(n,1)), y(max(n,1)), s
+ DOUBLE PRECISION x2(max(n,1)), y2(max(n,1)), s2
+ DOUBLE PRECISION x3(max(n,1)), y3(max(n,1)), s3
+ INTEGER von, bis
+ DOUBLE PRECISION qddot
+ EXTERNAL qddot
+ DOUBLE PRECISION ddot
+ EXTERNAL ddot
+
+ lsum(1) = 0.0D0
+ lsum(2) = 0.0D0
+ lsum(3) = 0.0D0
+! blocking
+ DO von = 1, n, int(bl_size/bldiv_dot(2))
+ bis = min(n,von+int(bl_size/bldiv_dot(2))-1)
+! compute local-sum
+#ifdef USE_QDDOT
+ lsum(1) = lsum(1) + qddot(bis-von+1,x(von),1,y(von),1)
+ lsum(2) = lsum(2) + qddot(bis-von+1,x2(von),1,y2(von),1)
+ lsum(3) = lsum(3) + qddot(bis-von+1,x3(von),1,y3(von),1)
+#else
+ lsum(1) = lsum(1) + ddot(bis-von+1,x(von),1,y(von),1)
+ lsum(2) = lsum(2) + ddot(bis-von+1,x2(von),1,y2(von),1)
+ lsum(3) = lsum(3) + ddot(bis-von+1,x3(von),1,y3(von),1)
+#endif
+ END DO
+! compute global sum (OpenMP)
+ CALL xsum_0(3,lsum,slsum,sh_help)
+ s = slsum(1)
+ s2 = slsum(2)
+ s3 = slsum(3)
+ RETURN
+ END
+
+!> @brief 4x compute ([x]^T*[y]) distributed and build a global sum, (OpenMP version)
+!> @param[in] N length of all vectors
+!> @param[in] X vector [x]
+!> @param[in] X2 vector [x]
+!> @param[in] X3 vector [x]
+!> @param[in] X4 vector [x]
+!> @param[in] Y vector [y]
+!> @param[in] Y2 vector [y]
+!> @param[in] Y3 vector [y]
+!> @param[in] Y4 vector [y]
+!> @param[in] sh_help openmp-shared vector [# threads *4]
+!> @param[out] S solution ( [x]^T*[y] )
+!> @param[out] S2 solution ( [x]^T*[y] )
+!> @param[out] S3 solution ( [x]^T*[y] )
+!> @param[out] S4 solution ( [x]^T*[y] )
+!> @details
+!> Function : compute ([x]^T*[y]) distributed and build a global sum,\n
+!> 4 products at once\n
+ SUBROUTINE omp_4ddot(n,x,y,s,x2,y2,s2,x3,y3,s3,x4,y4,s4,sh_help)
+ use mod_OMP_TOOLS
+ use mod_blocking_size
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+! N : length of all vector x,y
+ INTEGER n
+! lsum : local-summary
+! lsum : source summary, don't do that
+! vectors [x], [y]
+ DOUBLE PRECISION lsum(4), slsum(4), sh_help(*)
+ DOUBLE PRECISION x(max(n,1)), y(max(n,1)), s
+ DOUBLE PRECISION x2(max(n,1)), y2(max(n,1)), s2
+ DOUBLE PRECISION x3(max(n,1)), y3(max(n,1)), s3
+ DOUBLE PRECISION x4(max(n,1)), y4(max(n,1)), s4
+ INTEGER von, bis
+ DOUBLE PRECISION qddot
+ EXTERNAL qddot
+ DOUBLE PRECISION ddot
+ EXTERNAL ddot
+
+ lsum(1) = 0.0D0
+ lsum(2) = 0.0D0
+ lsum(3) = 0.0D0
+ lsum(4) = 0.0D0
+! blocking
+ DO von = 1, n, int(bl_size/bldiv_dot(3))
+ bis = min(n,von+int(bl_size/bldiv_dot(3))-1)
+! compute local-sum
+#ifdef USE_QDDOT
+ lsum(1) = lsum(1) + qddot(bis-von+1,x(von),1,y(von),1)
+ lsum(2) = lsum(2) + qddot(bis-von+1,x2(von),1,y2(von),1)
+ lsum(3) = lsum(3) + qddot(bis-von+1,x3(von),1,y3(von),1)
+ lsum(4) = lsum(4) + qddot(bis-von+1,x4(von),1,y4(von),1)
+#else
+ lsum(1) = lsum(1) + ddot(bis-von+1,x(von),1,y(von),1)
+ lsum(2) = lsum(2) + ddot(bis-von+1,x2(von),1,y2(von),1)
+ lsum(3) = lsum(3) + ddot(bis-von+1,x3(von),1,y3(von),1)
+ lsum(4) = lsum(4) + ddot(bis-von+1,x4(von),1,y4(von),1)
+#endif
+ END DO
+! compute global sum (OpenMP)
+ CALL xsum_0(4,lsum,slsum,sh_help)
+ s = slsum(1)
+ s2 = slsum(2)
+ s3 = slsum(3)
+ s4 = slsum(4)
+ RETURN
+ END
diff --git a/solve/omp_gen_solve.f90 b/solve/omp_gen_solve.f90
new file mode 100644
index 0000000..eca3343
--- /dev/null
+++ b/solve/omp_gen_solve.f90
@@ -0,0 +1,207 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief solve of : [M] x [x] = [b], BICGSTAB algorithm based
+!> @param[in] N_I lengths of I dimension of local matrix [M]
+!> @param[in] N_J lengths of J dimension of local matrix [M]
+!> @param[in] N_K lengths of K dimension of local matrix [M]
+!> @param[in,out] x solution vector [x], on start = start vector
+!> @param[in] b right side, vector [b]
+!> @param[in] r0_hat random vector [r0_hat] ^= [r0^]
+!> @param[in] depsilon precision criteria to break iterations
+!> @param[in] max_It max iteration number
+!> @param[in] criteria precision criteria mode to break iterations\n
+!> - 0 : relative stopping crit.: ||[res]|| < depsilon*||[res0]||\n
+!> - 1 : absolute stopping crit.: ||[res]|| < depsilon\n
+!> - 2 : maximum stopping crit.: max(abs([res])) < depsilon\n
+!> first [res]^=[r], later (if precise enough): [res]^=([M]x[x]-[b])
+!> @param[in] mbc_mask boundary condition pattern (mask)
+!> @param[in] MA 1. diagonal of the system matrix [M]
+!> @param[in] MB 2. diagonal of the system matrix [M]
+!> @param[in] MC 3. diagonal of the system matrix [M]
+!> @param[in] MD 4. diagonal of the system matrix [M]
+!> @param[in] ME 5. diagonal of the system matrix [M]
+!> @param[in] MF 6. diagonal of the system matrix [M]
+!> @param[in] MG 7. diagonal of the system matrix [M]
+!> @param[out] locTMP local temporary vectors
+!> @param[out] dnrm normalisation vector, temporary use
+!> @param[in] ismpl local sample index
+!> @details
+!> solve of : [M] x [x] = [b]\n
+!> [M] is general Matrix, only used in 'omp_MVP'\n
+!> Technics :\n
+!> - use reverse communication technics.\n
+!> each vector should be dense full without any hole,\n
+!> ( you can copy your elements from your structure to a \n
+!> temporary dense full vector, befor you use this algorithm \n
+!> and give the correct number of elements in 'N' ).\n
+!> if you have setup all vectors by a specific composition,\n
+!> each vector (x,b,r,...) on the same thread should use\n
+!> the same composition (same structure for all vectors on\n
+!> one thread).\n
+ SUBROUTINE omp_gen_solve(n_i,n_j,n_k,x,b,r0_hat,depsilon, &
+ mbc_mask,max_it,criteria,ma,mb,mc,md,me,mf,mg,loctmp,dnrm, &
+ ismpl)
+ use mod_OMP_TOOLS
+ use mod_blocking_size
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+
+! N : length of all vector r,z,s,t,v,p,y,t_pc,s_pc
+ INTEGER n, n_i, n_j, n_k, max_it, ismpl
+
+! thread stuff
+ INTEGER tpos, tanz
+
+! vector x and b for [M]x[x]=[b]
+! res0 ^= ||res0||, start residuel, given for 'criteria=0'
+ DOUBLE PRECISION x(n_i*n_j*n_k), b(n_i*n_j*n_k)
+ DOUBLE PRECISION r0_hat(n_i*n_j*n_k), res0
+ CHARACTER mbc_mask(n_i*n_j*n_k)
+ DOUBLE PRECISION ma(n_i*n_j*n_k), mb(n_i*n_j*n_k), &
+ mc(n_i*n_j*n_k)
+ DOUBLE PRECISION md(n_i*n_j*n_k), me(n_i*n_j*n_k), &
+ mf(n_i*n_j*n_k)
+ DOUBLE PRECISION mg(n_i*n_j*n_k)
+
+! definitions of 'work' and 'locTMP'
+ INCLUDE 'pre_bicgstab.inc'
+! locTMP : space for local vectors, using to exchange data with
+! 'matrix-vector-product'(MVP) and 'pre-conditioners'(L/R),
+! for definitions see more in 'pre_bicgstab.inc'
+ DOUBLE PRECISION loctmp(n_i*n_j*n_k,max_loctmp)
+ DOUBLE PRECISION dnrm(n_i*n_j*n_k)
+
+! Pre_BiCGStab stuff
+! work : control variable : what is to do in this subroutine,
+! see more discription in 'pre_bicgstab.inc',
+! on startup should set to 'work=START'
+ INTEGER work
+
+! break with enough precision
+ DOUBLE PRECISION depsilon
+
+ INTEGER criteria
+
+ ! INTEGER l, wieviele
+ ! DOUBLE PRECISION dmaxi, dmini, durchs
+! openmp-shared variables
+ INTEGER ipar(5), iii
+ DOUBLE PRECISION, ALLOCATABLE :: rpar(:)
+ LOGICAL lpar(1)
+
+
+! full number of elements
+ n = n_i*n_j*n_k
+ res0 = 1.D+99
+
+
+!**************************************************************
+
+! start values
+ work = start
+
+!$OMP parallel &
+!$OMP num_threads(Tlevel_1)&
+!$OMP default(shared)&
+!$OMP private(tanz,tpos,iii)
+!$ call omp_binding(ismpl)
+
+ CALL omp_part(n,tpos,tanz)
+
+!$OMP master
+ iii = 5 + 4*omp_get_num_of_threads()
+ ALLOCATE(rpar(iii))
+ CALL set_dval(iii,0.D0,rpar)
+!$OMP end master
+! normalise the linear system, use [dnrm] to normalise the system
+ CALL norm_linsys(tanz,mbc_mask(tpos),b(tpos),x(tpos),ma(tpos), &
+ mb(tpos),mc(tpos),md(tpos),me(tpos),mf(tpos),mg(tpos), &
+ dnrm(tpos))
+!$OMP barrier
+
+! preload ([M]x[x]) in [z]
+ CALL omp_mvp(n_i,n_j,n_k,x,loctmp(1,z),ma,mb,mc,md,me,mf,mg)
+! impliciete barrier here
+
+10 CONTINUE
+
+
+! BiCGStab routine
+ CALL pre_bicgstab(tanz,x(tpos),b(tpos),r0_hat(tpos),n, &
+ loctmp(tpos,1),depsilon,dnrm(tpos),max_it,criteria,res0, &
+ work,ipar,rpar,lpar)
+! impliciete barrier here
+
+! preconditioner [y]:=[K^-1]x[p],
+! matrix-vector product [v]:=[M]x[y]
+ IF ((work==do_y_p_v) .OR. (work==more_y_p_v)) THEN
+! left precond.
+ CALL myprco(n,loctmp(1,p),loctmp(1,t_pc))
+! right precond.
+ CALL myprco(n,loctmp(1,t_pc),loctmp(1,y))
+!$OMP barrier
+
+ CALL omp_mvp(n_i,n_j,n_k,loctmp(1,y),loctmp(1,v),ma,mb,mc, &
+ md,me,mf,mg)
+! implicit barrier here
+ END IF
+
+! [z]:=[M]x[x], for advanced precision
+ IF (work==more_y_p_v) CALL omp_mvp(n_i,n_j,n_k,x,loctmp(1,z), &
+ ma,mb,mc,md,me,mf,mg)
+! impliciete barrier here
+
+! preconditioner [z]:=[K^-1]x[s],
+! preconditioner [s_pc]:=[L_K^-1]x[s],
+! matrix-vector product [t]:=[M]x[z],
+! preconditioner [t_pc]:=[L_K^-1]x[t]
+ IF (work==do_z_s_t) THEN
+! left precond.
+ CALL myprco(n,loctmp(1,s),loctmp(1,s_pc))
+! right precond.
+ CALL myprco(n,loctmp(1,s_pc),loctmp(1,z))
+!$OMP barrier
+
+ CALL omp_mvp(n_i,n_j,n_k,loctmp(1,z),loctmp(1,t),ma,mb,mc, &
+ md,me,mf,mg)
+! implicit barrier here
+
+! left precond.
+ CALL myprco(n,loctmp(1,t),loctmp(1,t_pc))
+!$OMP barrier
+ END IF
+
+
+! precision not enough ?
+ IF ((work/=fine) .AND. (work/=abort)) GO TO 10
+! at "work=ABORT", we can startup with a new [r^]
+
+!$OMP end parallel
+
+ DEALLOCATE(rpar)
+
+!**************************************************************
+
+
+ RETURN
+ END
diff --git a/solve/omp_gen_solve_diag.f90 b/solve/omp_gen_solve_diag.f90
new file mode 100644
index 0000000..2de7c20
--- /dev/null
+++ b/solve/omp_gen_solve_diag.f90
@@ -0,0 +1,208 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief solve of : [M] x [x] = [b], BICGSTAB algorithm based with Diagonal preconditioning
+!> @param[in] N_I lengths of I dimension of local matrix [M]
+!> @param[in] N_J lengths of J dimension of local matrix [M]
+!> @param[in] N_K lengths of K dimension of local matrix [M]
+!> @param[in,out] x solution vector [x], on start = start vector
+!> @param[in] b right side, vector [b]
+!> @param[in] r0_hat random vector [r0_hat] ^= [r0^]
+!> @param[in] depsilon precision criteria to break iterations
+!> @param[in] max_It max iteration number
+!> @param[in] criteria precision criteria mode to break iterations\n
+!> - 0 : relative stopping crit.: ||[res]|| < depsilon*||[res0]||\n
+!> - 1 : absolute stopping crit.: ||[res]|| < depsilon\n
+!> - 2 : maximum stopping crit.: max(abs([res])) < depsilon\n
+!> first [res]^=[r], later (if precise enough): [res]^=([M]x[x]-[b])
+!> @param[in] mbc_mask boundary condition pattern (mask)
+!> @param[in] MA 1. diagonal of the system matrix [M]
+!> @param[in] MB 2. diagonal of the system matrix [M]
+!> @param[in] MC 3. diagonal of the system matrix [M]
+!> @param[in] MD 4. diagonal of the system matrix [M]
+!> @param[in] ME 5. diagonal of the system matrix [M]
+!> @param[in] MF 6. diagonal of the system matrix [M]
+!> @param[in] MG 7. diagonal of the system matrix [M]
+!> @param[out] locTMP local temporary vectors
+!> @param[out] dnrm normalisation vector, temporary use
+!> @param[in] ismpl local sample index
+!> @details
+!> solve of : [M] x [x] = [b]\n
+!> [M] is general Matrix, only used in 'omp_MVP'\n
+!> Technics :\n
+! - use reverse communication technics.\n
+!> each vector should be dense full without any hole,\n
+!> ( you can copy your elements from your structure to a \n
+!> temporary dense full vector, befor you use this algorithm \n
+!> and give the correct number of elements in 'N' ).\n
+!> if you have setup all vectors by a specific composition,\n
+!> each vector (x,b,r,...) on the same thread should use\n
+!> the same composition (same structure for all vectors on\n
+!> one thread).\n
+ SUBROUTINE omp_gen_solve_diag(n_i,n_j,n_k,x,b,r0_hat,depsilon, &
+ mbc_mask,max_it,criteria,ma,mb,mc,md,me,mf,mg,loctmp,dnrm, &
+ ismpl)
+ use mod_OMP_TOOLS
+ use mod_blocking_size
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+
+! N : length of all vector r,z,s,t,v,p,y,t_pc,s_pc
+ INTEGER n, n_i, n_j, n_k, max_it, ismpl
+
+! thread stuff
+ INTEGER tpos, tanz
+
+! vector x and b for [M]x[x]=[b]
+! res0 ^= ||res0||, start residuel, given for 'criteria=0'
+ DOUBLE PRECISION x(n_i*n_j*n_k), b(n_i*n_j*n_k)
+ DOUBLE PRECISION r0_hat(n_i*n_j*n_k), res0
+ CHARACTER mbc_mask(n_i*n_j*n_k)
+ DOUBLE PRECISION ma(n_i*n_j*n_k), mb(n_i*n_j*n_k), &
+ mc(n_i*n_j*n_k)
+ DOUBLE PRECISION md(n_i*n_j*n_k), me(n_i*n_j*n_k), &
+ mf(n_i*n_j*n_k)
+ DOUBLE PRECISION mg(n_i*n_j*n_k)
+
+! definitions of 'work' and 'locTMP'
+ INCLUDE 'pre_bicgstab.inc'
+! locTMP : space for local vectors, using to exchange data with
+! 'matrix-vector-product'(MVP) and 'pre-conditioners'(L/R),
+! for definitions see more in 'pre_bicgstab.inc'
+ DOUBLE PRECISION loctmp(n_i*n_j*n_k,max_loctmp)
+ DOUBLE PRECISION dnrm(n_i*n_j*n_k)
+
+! Pre_BiCGStab stuff
+! work : control variable : what is to do in this subroutine,
+! see more discription in 'pre_bicgstab.inc',
+! on startup should set to 'work=START'
+ INTEGER work
+
+! break with enough precision
+ DOUBLE PRECISION depsilon
+
+ INTEGER criteria
+
+ ! INTEGER l, wieviele
+ ! DOUBLE PRECISION dmaxi, dmini, durchs
+! openmp-shared variables
+ INTEGER ipar(5), iii
+ DOUBLE PRECISION, ALLOCATABLE :: rpar(:)
+ LOGICAL lpar(1)
+
+
+! full number of elements
+ n = n_i*n_j*n_k
+ res0 = 1.D+99
+
+
+!**************************************************************
+
+! start values
+ work = start
+
+!$OMP parallel &
+!$OMP num_threads(Tlevel_1)&
+!$OMP default(shared)&
+!$OMP private(tanz,tpos, iii)
+!$ call omp_binding(ismpl)
+
+ CALL omp_part(n,tpos,tanz)
+
+!$OMP master
+ iii = 5 + 4*omp_get_num_of_threads()
+ ALLOCATE(rpar(iii))
+ CALL set_dval(iii,0.D0,rpar)
+! allocate(rpar(5 +4 *OMP_GET_NUM_of_THREADS()))
+!$OMP end master
+! normalise the linear system, use [dnrm] to normalise the system
+ CALL norm_linsys(tanz,mbc_mask(tpos),b(tpos),x(tpos),ma(tpos), &
+ mb(tpos),mc(tpos),md(tpos),me(tpos),mf(tpos),mg(tpos), &
+ dnrm(tpos))
+!$OMP barrier
+
+! preload ([M]x[x]) in [z]
+ CALL omp_mvp(n_i,n_j,n_k,x,loctmp(1,z),ma,mb,mc,md,me,mf,mg)
+! impliciete barrier here
+
+10 CONTINUE
+
+
+! BiCGStab routine
+ CALL pre_bicgstab(tanz,x(tpos),b(tpos),r0_hat(tpos),n, &
+ loctmp(tpos,1),depsilon,dnrm(tpos),max_it,criteria,res0, &
+ work,ipar,rpar,lpar)
+! impliciete barrier here
+
+! preconditioner [y]:=[K^-1]x[p],
+! matrix-vector product [v]:=[M]x[y]
+ IF ((work==do_y_p_v) .OR. (work==more_y_p_v)) THEN
+! left precond.
+ CALL diagprco(n,md,loctmp(1,p),loctmp(1,t_pc))
+! right precond.
+ CALL myprco(n,loctmp(1,t_pc),loctmp(1,y))
+!$OMP barrier
+
+ CALL omp_mvp(n_i,n_j,n_k,loctmp(1,y),loctmp(1,v),ma,mb,mc, &
+ md,me,mf,mg)
+! implicit barrier here
+ END IF
+
+! [z]:=[M]x[x], for advanced precision
+ IF (work==more_y_p_v) CALL omp_mvp(n_i,n_j,n_k,x,loctmp(1,z), &
+ ma,mb,mc,md,me,mf,mg)
+! impliciete barrier here
+
+! preconditioner [z]:=[K^-1]x[s],
+! preconditioner [s_pc]:=[L_K^-1]x[s],
+! matrix-vector product [t]:=[M]x[z],
+! preconditioner [t_pc]:=[L_K^-1]x[t]
+ IF (work==do_z_s_t) THEN
+! left precond.
+ CALL diagprco(n,md,loctmp(1,s),loctmp(1,s_pc))
+! right precond.
+ CALL myprco(n,loctmp(1,s_pc),loctmp(1,z))
+!$OMP barrier
+
+ CALL omp_mvp(n_i,n_j,n_k,loctmp(1,z),loctmp(1,t),ma,mb,mc, &
+ md,me,mf,mg)
+! implicit barrier here
+
+! left precond.
+ CALL diagprco(n,md,loctmp(1,t),loctmp(1,t_pc))
+!$OMP barrier
+ END IF
+
+
+! precision not enough ?
+ IF ((work/=fine) .AND. (work/=abort)) GO TO 10
+! at "work=ABORT", we can startup with a new [r^]
+
+!$OMP end parallel
+
+ DEALLOCATE(rpar)
+
+!**************************************************************
+
+
+ RETURN
+ END
diff --git a/solve/omp_gen_solve_ilu.f90 b/solve/omp_gen_solve_ilu.f90
new file mode 100644
index 0000000..058e9a6
--- /dev/null
+++ b/solve/omp_gen_solve_ilu.f90
@@ -0,0 +1,326 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief solve of : [M] x [x] = [b], BICGSTAB algorithm based with ILU preconditioning
+!> @param[in] N_I lengths of I dimension of local matrix [M]
+!> @param[in] N_J lengths of J dimension of local matrix [M]
+!> @param[in] N_K lengths of K dimension of local matrix [M]
+!> @param[in,out] x solution vector [x], on start = start vector
+!> @param[in] b right side, vector [b]
+!> @param[in] r0_hat random vector [r0_hat] ^= [r0^]
+!> @param[in] depsilon precision criteria to break iterations
+!> @param[in] mbc_mask boundary condition pattern (mask)
+!> @param[in] max_It max iteration number
+!> @param[in] criteria precision criteria mode to break iterations\n
+!> - 0 : relative stopping crit.: ||[res]|| < depsilon*||[res0]||\n
+!> - 1 : absolute stopping crit.: ||[res]|| < depsilon\n
+!> - 2 : maximum stopping crit.: max(abs([res])) < depsilon\n
+!> first [res]^=[r], later (if precise enough): [res]^=([M]x[x]-[b])
+!> @param[in] MA 1. diagonal of the system matrix [M]
+!> @param[in] MB 2. diagonal of the system matrix [M]
+!> @param[in] MC 3. diagonal of the system matrix [M]
+!> @param[in] MD 4. diagonal of the system matrix [M]
+!> @param[in] ME 5. diagonal of the system matrix [M]
+!> @param[in] MF 6. diagonal of the system matrix [M]
+!> @param[in] MG 7. diagonal of the system matrix [M]
+!> @param[in] UD helper diagonal elements for preconditioning
+!> @param[out] bound_block boundary exchange buffer for each block, between the threads
+!> @param[out] dnrm normalisation vector, temporary use
+!> @param[out] lMA temporary thread local elements of the 1. diagonal of [M]
+!> @param[out] lMB temporary thread local elements of the 2. diagonal of [M]
+!> @param[out] lMC temporary thread local elements of the 3. diagonal of [M]
+!> @param[out] lMD temporary thread local elements of the 4. diagonal of [M]
+!> @param[out] lME temporary thread local elements of the 5. diagonal of [M]
+!> @param[out] lMF temporary thread local elements of the 6. diagonal of [M]
+!> @param[out] lMG temporary thread local elements of the 7. diagonal of [M]
+!> @param[out] lUD temporary thread local elements of the helper diagonal [UD]
+!> @param[out] lx temporary thread local elements of the solution vector [x]
+!> @param[out] lb temporary thread local elements of the right side [b]
+!> @param[out] lr0_hat temporary thread local elements of the random vector [r0_hat]
+!> @param[out] ldnrm temporary thread local elements of the normalisation vector
+!> @param[out] llocTMP temporary thread local elements of the local temporary vectors
+!> @param[out] ud_block block buffer for helper diagonal [UD]
+!> @param[in] ismpl local sample index
+!> @details
+!> solve of : [M] x [x] = [b]\n
+!> [M] is general Matrix, only used in 'omp_MVP'\n
+!> Technics :\n
+!> - use reverse communication technics.\n
+!> each vector should be dense full without any hole,\n
+!> ( you can copy your elements from your structure to a \n
+!> temporary dense full vector, befor you use this algorithm \n
+!> and give the correct number of elements in 'N' ).\n
+!> if you have setup all vectors by a specific composition,\n
+!> each vector (x,b,r,...) on the same thread should use\n
+!> the same composition (same structure for all vectors on\n
+!> one thread).\n
+ SUBROUTINE omp_gen_solve_ilu(n_i,n_j,n_k,x,b,r0_hat,depsilon, &
+ mbc_mask,max_it,criteria,ma,mb,mc,md,me,mf,mg,ud, &
+ bound_block,dnrm,lma,lmb,lmc,lmd,lme,lmf,lmg,lud,lx,lb, &
+ lr0_hat,ldnrm,lloctmp,ud_block,ismpl)
+ use mod_OMP_TOOLS
+ use mod_blocking_size
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+
+! N_I*N_J*N_K : length of all vector r,z,s,t,v,p,y,t_pc,s_pc
+ INTEGER n_i, n_j, n_k, max_it, ismpl
+
+! vector x and b for [M]x[x]=[b]
+! res0 ^= ||res0||, start residuel, given for 'criteria=0'
+ DOUBLE PRECISION x(n_i*n_j*n_k), b(n_i*n_j*n_k)
+ DOUBLE PRECISION r0_hat(n_i*n_j*n_k), res0, ud(n_i*n_j*n_k)
+ DOUBLE PRECISION ma(n_i*n_j*n_k), mb(n_i*n_j*n_k)
+ DOUBLE PRECISION mc(n_i*n_j*n_k), md(n_i*n_j*n_k)
+ DOUBLE PRECISION me(n_i*n_j*n_k), mf(n_i*n_j*n_k)
+ DOUBLE PRECISION mg(n_i*n_j*n_k)
+ CHARACTER mbc_mask(n_i*n_j*n_k)
+
+! definitions of 'work' and 'locTMP'
+ INCLUDE 'pre_bicgstab.inc'
+! locTMP : space for local vectors, using to exchange data with
+! 'matrix-vector-product'(MVP) and 'pre-conditioners'(L/R),
+! for definitions see more in 'pre_bicgstab.inc'
+
+! global buffer for boundary exchange
+ DOUBLE PRECISION dnrm(n_i*n_j*n_k)
+ DOUBLE PRECISION bound_block(block_i*block_j+block_i*block_k+block_j*block_k,bdim_i,bdim_j,bdim_k,2)
+! private copy for preconditioning
+ DOUBLE PRECISION lma(max_blocks*block_i*block_j*block_k, tlevel_1)
+ DOUBLE PRECISION lmb(max_blocks*block_i*block_j*block_k, tlevel_1)
+ DOUBLE PRECISION lmc(max_blocks*block_i*block_j*block_k, tlevel_1)
+ DOUBLE PRECISION lmd(max_blocks*block_i*block_j*block_k, tlevel_1)
+ DOUBLE PRECISION lme(max_blocks*block_i*block_j*block_k, tlevel_1)
+ DOUBLE PRECISION lmf(max_blocks*block_i*block_j*block_k, tlevel_1)
+ DOUBLE PRECISION lmg(max_blocks*block_i*block_j*block_k, tlevel_1)
+ DOUBLE PRECISION lud(max_blocks*block_i*block_j*block_k, tlevel_1)
+ DOUBLE PRECISION lx(max_blocks*block_i*block_j*block_k, tlevel_1)
+ DOUBLE PRECISION lb(max_blocks*block_i*block_j*block_k, tlevel_1)
+ DOUBLE PRECISION lr0_hat(max_blocks*block_i*block_j*block_k, tlevel_1)
+ DOUBLE PRECISION ldnrm(max_blocks*block_i*block_j*block_k, tlevel_1)
+ DOUBLE PRECISION lloctmp(max_blocks*block_i*block_j*block_k, max_loctmp,tlevel_1)
+ DOUBLE PRECISION ud_block(block_i*block_j+block_i*block_k+block_j*block_k,max_blocks,tlevel_1)
+
+! x,y,z-grid index for each block position
+ INTEGER, ALLOCATABLE :: xyz_block(:,:)
+ INTEGER lxyz_block, tid
+
+! Pre_BiCGStab stuff
+! work : control variable : what is to do in this subroutine,
+! see more discription in 'pre_bicgstab.inc',
+! on startup should set to 'work=START'
+ INTEGER work
+
+! break with enough precision
+ DOUBLE PRECISION depsilon, summ
+
+ INTEGER xi, yi, zi, loc_mem, loc_memm1
+ INTEGER criteria, i, j, k, fkt_proza
+ EXTERNAL fkt_proza
+! openmp-private variables
+ INTEGER tpos, tanz
+! openmp-shared variables
+ INTEGER ipar(5), iii
+ DOUBLE PRECISION, ALLOCATABLE :: rpar(:)
+ INTEGER, ALLOCATABLE :: proza_lock(:,:,:)
+ LOGICAL lpar(1)
+
+
+! start values
+ work = start
+ res0 = 1.D+99
+
+ ALLOCATE(proza_lock(bdim_i,bdim_j,bdim_k))
+! init
+ CALL set_ival(5,0,ipar)
+ CALL par_reset(proza_lock)
+ lpar(1) = .FALSE.
+
+!$OMP parallel &
+!$OMP num_threads(Tlevel_1) &
+!$OMP default(none) shared(Tlevel_1,ismpl) &
+!$OMP shared(block_i,block_j,block_k, bdim_i,bdim_j,bdim_k,ipar,rpar) &
+!$OMP shared(N_I,N_J,N_K, depsilon, max_It, criteria, res0, work,lpar) &
+!$OMP shared(bound_block,MA,MB,MC,MD,ME,MF,MG,UD,x,b,r0_hat,ProzA_lock) &
+!$OMP shared(mbc_mask, dnrm, ud_block, ldnrm, max_blocks) &
+!$OMP shared(lMA,lMB,lMC,lMD,lUD,lME,lMF,lMG,lx,lb,lr0_hat,llocTMP) &
+!$OMP private(i,j,k, tid, loc_mem,loc_memm1, lxyz_block, xyz_block) &
+!$OMP private(xi,yi,zi,summ,iii, tpos, tanz)
+!$ call omp_binding(ismpl)
+
+ CALL omp_part(n_i*n_j*n_k,tpos,tanz)
+ tid = omp_get_his_thread_num() + 1
+
+!$OMP master
+! how many entries ?
+ iii = 5 + 4*omp_get_num_of_threads()
+ ALLOCATE(rpar(iii))
+ CALL set_dval(iii,0.D0,rpar)
+!$OMP end master
+! normalise the linear system, use [dnrm] to normalise the system
+ CALL norm_linsys(tanz,mbc_mask(tpos),b(tpos),x(tpos),ma(tpos), &
+ mb(tpos),mc(tpos),md(tpos),me(tpos),mf(tpos),mg(tpos), &
+ dnrm(tpos))
+!$OMP barrier
+! init ILU(0)-preconditioner, other start values
+ CALL prepare_ilu(n_i,n_j,n_k,ma,mb,mc,md,me,mf,mg,ud)
+
+! max number of private blocks = bdim_i*bdim_j*bdim_k
+ ALLOCATE(xyz_block(3,bdim_i*bdim_j*bdim_k))
+
+ lxyz_block = 0
+ DO k = 1, bdim_k
+ DO j = 1, bdim_j
+ DO i = 1, bdim_i
+ IF (fkt_proza(i,j,k)==tid-1) THEN
+! compute number of private blocks
+ lxyz_block = lxyz_block + 1
+! setup index information for each private block
+ xyz_block(1,lxyz_block) = i
+ xyz_block(2,lxyz_block) = j
+ xyz_block(3,lxyz_block) = k
+ END IF
+ END DO
+ END DO
+ END DO
+! memory requirements
+ loc_mem = lxyz_block*block_i*block_j*block_k
+ loc_memm1 = max_blocks*block_i*block_j*block_k
+
+! make private copies from the global arrays
+!$OMP barrier
+ CALL lcopy_ilu(n_i,n_j,n_k,ma,lma(1,tid),lxyz_block,xyz_block)
+ CALL lcopy_ilu(n_i,n_j,n_k,mb,lmb(1,tid),lxyz_block,xyz_block)
+ CALL lcopy_ilu(n_i,n_j,n_k,mc,lmc(1,tid),lxyz_block,xyz_block)
+ CALL lcopy_ilu(n_i,n_j,n_k,md,lmd(1,tid),lxyz_block,xyz_block)
+ CALL lcopy_ilu(n_i,n_j,n_k,ud,lud(1,tid),lxyz_block,xyz_block)
+ CALL lcopy_ilu(n_i,n_j,n_k,me,lme(1,tid),lxyz_block,xyz_block)
+ CALL lcopy_ilu(n_i,n_j,n_k,mf,lmf(1,tid),lxyz_block,xyz_block)
+ CALL lcopy_ilu(n_i,n_j,n_k,mg,lmg(1,tid),lxyz_block,xyz_block)
+ CALL lcopy_ilu(n_i,n_j,n_k,x,lx(1,tid),lxyz_block,xyz_block)
+ CALL lcopy_ilu(n_i,n_j,n_k,b,lb(1,tid),lxyz_block,xyz_block)
+ CALL lcopy_ilu(n_i,n_j,n_k,dnrm,ldnrm(1,tid),lxyz_block,xyz_block)
+ CALL lcopy_ilu(n_i,n_j,n_k,r0_hat,lr0_hat(1,tid),lxyz_block,xyz_block)
+! lcopy_ilu of [locTMP] not needed, but of the cleanup
+!aw-test Call set_dval(loC_memm1*max_loCTMP,0.d0,lloCTMP(1,1,tid))
+
+! copy private [UD] surface (position-1)
+ DO i = 1, lxyz_block
+ CALL lsurf_ilu(n_i,n_j,n_k,i,ud,ud_block(1,i,tid),lxyz_block,xyz_block)
+ END DO
+
+
+! INIT
+! preload ([M]x[x]) in [z]
+ CALL omp_mvp2(n_i,n_j,n_k,lxyz_block,lx(1,tid), &
+ lloctmp(1,z,tid),lma(1,tid),lmb(1,tid),lmc(1,tid), &
+ lmd(1,tid),lme(1,tid),lmf(1,tid),lmg(1,tid),bound_block, &
+ xyz_block)
+
+!**************************************************************
+
+10 CONTINUE
+
+! BiCGStab routine
+ CALL pre_bicgstab(loc_mem,lx(1,tid),lb(1,tid),lr0_hat(1,tid), &
+ loc_memm1,lloctmp(1,1,tid),depsilon,ldnrm(1,tid),max_it, &
+ criteria,res0,work,ipar,rpar,lpar)
+! implicit barrier here
+
+! preconditioner [y]:=[K^-1]x[p],
+! matrix-vector product [v]:=[M]x[y]
+ IF ((work==do_y_p_v) .OR. (work==more_y_p_v)) THEN
+! left precond.
+ CALL omp_lu_solve2(n_i,n_j,n_k,lxyz_block,lloctmp(1,p,tid), &
+ lloctmp(1,t_pc,tid),lma(1,tid),lmb(1,tid),lmc(1,tid), &
+ lud(1,tid),lme(1,tid),lmf(1,tid),lmg(1,tid), &
+ ud_block(1,1,tid),bound_block,xyz_block,proza_lock)
+! needs barrier here, [LU] and [MVP] modify "bound_block"
+!$OMP barrier
+! right precond.
+! : call myPrCo(N,locTMP(1,t_pc),locTMP(1,y))
+ CALL dcopy(loc_mem,lloctmp(1,t_pc,tid),1,lloctmp(1,y,tid),1)
+! MVP
+ CALL omp_mvp2(n_i,n_j,n_k,lxyz_block,lloctmp(1,y,tid), &
+ lloctmp(1,v,tid),lma(1,tid),lmb(1,tid),lmc(1,tid), &
+ lmd(1,tid),lme(1,tid),lmf(1,tid),lmg(1,tid),bound_block, &
+ xyz_block)
+ END IF
+
+! [z]:=[M]x[x], for advanced precision
+ IF (work==more_y_p_v) THEN
+! needs barrier here, both [MVP] calls modify "bound_block"
+!$OMP barrier
+ CALL omp_mvp2(n_i,n_j,n_k,lxyz_block,lx(1,tid), &
+ lloctmp(1,z,tid),lma(1,tid),lmb(1,tid),lmc(1,tid), &
+ lmd(1,tid),lme(1,tid),lmf(1,tid),lmg(1,tid),bound_block, &
+ xyz_block)
+ END IF
+
+! preconditioner [z]:=[K^-1]x[s],
+! preconditioner [s_pc]:=[L_K^-1]x[s],
+! matrix-vector product [t]:=[M]x[z],
+! preconditioner [t_pc]:=[L_K^-1]x[t]
+ IF (work==do_z_s_t) THEN
+! left precond.
+ CALL omp_lu_solve2(n_i,n_j,n_k,lxyz_block,lloctmp(1,s,tid), &
+ lloctmp(1,s_pc,tid),lma(1,tid),lmb(1,tid),lmc(1,tid), &
+ lud(1,tid),lme(1,tid),lmf(1,tid),lmg(1,tid), &
+ ud_block(1,1,tid),bound_block,xyz_block,proza_lock)
+! needs barrier here, [LU] and [MVP] modify "bound_block"
+!$OMP barrier
+! right precond.
+! : call myPrCo(N,locTMP(1,s_pc),locTMP(1,z))
+ CALL dcopy(loc_mem,lloctmp(1,s_pc,tid),1,lloctmp(1,z,tid),1)
+! MVP
+ CALL omp_mvp2(n_i,n_j,n_k,lxyz_block,lloctmp(1,z,tid), &
+ lloctmp(1,t,tid),lma(1,tid),lmb(1,tid),lmc(1,tid), &
+ lmd(1,tid),lme(1,tid),lmf(1,tid),lmg(1,tid),bound_block, &
+ xyz_block)
+! needs barrier here, [MVP] and [LU] modify "bound_block"
+!$OMP barrier
+! left precond.
+ CALL omp_lu_solve2(n_i,n_j,n_k,lxyz_block,lloctmp(1,t,tid), &
+ lloctmp(1,t_pc,tid),lma(1,tid),lmb(1,tid),lmc(1,tid), &
+ lud(1,tid),lme(1,tid),lmf(1,tid),lmg(1,tid), &
+ ud_block(1,1,tid),bound_block,xyz_block,proza_lock)
+ END IF
+
+
+! precision not enough ?
+ IF ((work/=fine) .AND. (work/=abort)) GO TO 10
+! at "work=ABORT", we can startup with a new [r^]
+
+!**************************************************************
+
+
+! get the global [x] from private
+ CALL lcopy_bak_ilu(n_i,n_j,n_k,x,lx(1,tid),lxyz_block,xyz_block)
+
+ DEALLOCATE(xyz_block)
+
+!$OMP end parallel
+ DEALLOCATE(rpar)
+ DEALLOCATE(proza_lock)
+
+ RETURN
+ END
diff --git a/solve/omp_gen_solve_ssor.f90 b/solve/omp_gen_solve_ssor.f90
new file mode 100644
index 0000000..2b77f56
--- /dev/null
+++ b/solve/omp_gen_solve_ssor.f90
@@ -0,0 +1,225 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief solve of : [M] x [x] = [b], BICGSTAB algorithm based with SSOR preconditioning
+!> @param[in] N_I lengths of I dimension of local matrix [M]
+!> @param[in] N_J lengths of J dimension of local matrix [M]
+!> @param[in] N_K lengths of K dimension of local matrix [M]
+!> @param[in,out] x solution vector [x], on start = start vector
+!> @param[in] b right side, vector [b]
+!> @param[in] r0_hat random vector [r0_hat] ^= [r0^]
+!> @param[in] depsilon precision criteria to break iterations
+!> @param[in] max_It max iteration number
+!> @param[in] criteria precision criteria mode to break iterations\n
+!> - 0 : relative stopping crit.: ||[res]|| < depsilon*||[res0]||\n
+!> - 1 : absolute stopping crit.: ||[res]|| < depsilon\n
+!> - 2 : maximum stopping crit.: max(abs([res])) < depsilon\n
+!> first [res]^=[r], later (if precise enough): [res]^=([M]x[x]-[b])
+!> @param[in] mbc_mask boundary condition pattern (mask)
+!> @param[in] MA 1. diagonal of the system matrix [M]
+!> @param[in] MB 2. diagonal of the system matrix [M]
+!> @param[in] MC 3. diagonal of the system matrix [M]
+!> @param[in] MD 4. diagonal of the system matrix [M]
+!> @param[in] ME 5. diagonal of the system matrix [M]
+!> @param[in] MF 6. diagonal of the system matrix [M]
+!> @param[in] MG 7. diagonal of the system matrix [M]
+!> @param[out] locTMP local temporary vectors
+!> @param[out] dnrm normalisation vector, temporary use
+!> @param[in] ismpl local sample index
+!> @details
+!> solve of : [M] x [x] = [b]\n
+!> [M] is general Matrix, only used in 'omp_MVP'\n
+!> Technics :\n
+!> - use reverse communication technics.\n
+!> each vector should be dense full without any hole,\n
+!> ( you can copy your elements from your structure to a \n
+!> temporary dense full vector, befor you use this algorithm \n
+!> and give the correct number of elements in 'N' ).\n
+!> if you have setup all vectors by a specific composition,\n
+!> each vector (x,b,r,...) on the same thread should use\n
+!> the same composition (same structure for all vectors on\n
+!> one thread).\n
+ SUBROUTINE omp_gen_solve_ssor(n_i,n_j,n_k,x,b,r0_hat,depsilon, &
+ mbc_mask,max_it,criteria,ma,mb,mc,md,me,mf,mg,loctmp,dnrm, &
+ ismpl)
+ use mod_OMP_TOOLS
+ use mod_blocking_size
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+
+! N : length of all vector r,z,s,t,v,p,y,t_pc,s_pc
+ INTEGER n, n_i, n_j, n_k, max_it, ismpl
+
+! thread stuff
+ INTEGER tpos, tanz
+
+! vector x and b for [M]x[x]=[b]
+! res0 ^= ||res0||, start residuel, given for 'criteria=0'
+ DOUBLE PRECISION x(n_i*n_j*n_k), b(n_i*n_j*n_k)
+ DOUBLE PRECISION r0_hat(n_i*n_j*n_k), res0
+ CHARACTER mbc_mask(n_i*n_j*n_k)
+ DOUBLE PRECISION ma(n_i*n_j*n_k), mb(n_i*n_j*n_k), &
+ mc(n_i*n_j*n_k)
+ DOUBLE PRECISION md(n_i*n_j*n_k), me(n_i*n_j*n_k), &
+ mf(n_i*n_j*n_k)
+ DOUBLE PRECISION mg(n_i*n_j*n_k)
+
+! definitions of 'work' and 'locTMP'
+ INCLUDE 'pre_bicgstab.inc'
+! locTMP : space for local vectors, using to exchange data with
+! 'matrix-vector-product'(MVP) and 'pre-conditioners'(L/R),
+! for definitions see more in 'pre_bicgstab.inc'
+ DOUBLE PRECISION loctmp(n_i*n_j*n_k,max_loctmp)
+ DOUBLE PRECISION dnrm(n_i*n_j*n_k)
+
+! Pre_BiCGStab stuff
+! work : control variable : what is to do in this subroutine,
+! see more discription in 'pre_bicgstab.inc',
+! on startup should set to 'work=START'
+ INTEGER work
+
+! break with enough precision
+ DOUBLE PRECISION depsilon
+
+ INTEGER criteria
+! openmp-shared variables
+ INTEGER ipar(5), iii
+ DOUBLE PRECISION, ALLOCATABLE :: rpar(:)
+ LOGICAL lpar(1)
+
+
+! full number of elements
+ n = n_i*n_j*n_k
+ res0 = 1.D+99
+
+
+!**************************************************************
+
+! start values
+ work = start
+
+!$OMP parallel &
+!$OMP num_threads(Tlevel_1) &
+!$OMP default(shared) &
+!$OMP private(tanz,tpos,iii)
+!$ call omp_binding(ismpl)
+
+ CALL omp_part(n,tpos,tanz)
+
+!$OMP master
+ iii = 5 + 4*omp_get_num_of_threads()
+ ALLOCATE(rpar(iii))
+ CALL set_dval(iii,0.D0,rpar)
+! allocate(rpar(5 +4 *OMP_GET_NUM_of_THREADS()))
+!$OMP end master
+! normalise the linear system, use [dnrm] to normalise the system
+ CALL norm_linsys(tanz,mbc_mask(tpos),b(tpos),x(tpos),ma(tpos), &
+ mb(tpos),mc(tpos),md(tpos),me(tpos),mf(tpos),mg(tpos), &
+ dnrm(tpos))
+!$OMP barrier
+
+! ###################### not parallel Code !!! #########################
+! prepare [b^] from [b]
+! [b^] = D*(D+L)^(-1) * [b]
+ CALL ddl(n_i,n_j,n_k,b,loctmp(1,b_hat),ma,mb,mc,md)
+! implicit barrier here
+
+! prepare [r0~] from [r0^]
+! [r0~] = D*(D+L)^(-1) * [r0^]
+ CALL ddl(n_i,n_j,n_k,r0_hat,loctmp(1,r0_tilde),ma,mb,mc,md)
+! implicit barrier here
+! ################### above not parallel Code !!! ######################
+
+! preload ([M]x[x]) in [z]
+ CALL ssor_mvp_single(n_i,n_j,n_k,x,loctmp(1,z),loctmp(1,mt), &
+ ma,mb,mc,md,me,mf,mg)
+! implicit barrier here
+
+
+10 CONTINUE
+
+
+! BiCGStab routine
+ CALL pre_bicgstab(tanz,x(tpos),loctmp(tpos,b_hat), &
+ loctmp(tpos,r0_tilde),n,loctmp(tpos,1),depsilon,dnrm(tpos), &
+ max_it,criteria,res0,work,ipar,rpar,lpar)
+! implicit barrier here
+
+! preconditioner [y]:=[K^-1]x[p],
+! matrix-vector product [v]:=[M]x[y]
+ IF ((work==do_y_p_v) .OR. (work==more_y_p_v)) THEN
+! Left precond.
+ CALL myprco(n,loctmp(1,p),loctmp(1,t_pc))
+! Right precond.
+ CALL myprco(n,loctmp(1,t_pc),loctmp(1,y))
+!$OMP barrier
+
+ CALL ssor_mvp_single(n_i,n_j,n_k,loctmp(1,y),loctmp(1,v), &
+ loctmp(1,mt),ma,mb,mc,md,me,mf,mg)
+! impliciete barrier here
+ END IF
+
+! [z]:=[M]x[x], for advanced precision
+ IF (work==more_y_p_v) CALL ssor_mvp_single(n_i,n_j,n_k,x, &
+ loctmp(1,z),loctmp(1,mt),ma,mb,mc,md,me,mf,mg)
+! impliciete barrier here
+
+! preconditioner [z]:=[K^-1]x[s],
+! preconditioner [s_pc]:=[L_K^-1]x[s],
+! matrix-vector product [t]:=[M]x[z],
+! preconditioner [t_pc]:=[L_K^-1]x[t]
+ IF (work==do_z_s_t) THEN
+! Left precond.
+ CALL myprco(n,loctmp(1,s),loctmp(1,s_pc))
+! Right precond.
+ CALL myprco(n,loctmp(1,s_pc),loctmp(1,z))
+!$OMP barrier
+
+ CALL ssor_mvp_single(n_i,n_j,n_k,loctmp(1,z),loctmp(1,t), &
+ loctmp(1,mt),ma,mb,mc,md,me,mf,mg)
+! implicit barrier here
+
+! Left precond.
+ CALL myprco(n,loctmp(1,t),loctmp(1,t_pc))
+!$OMP barrier
+ END IF
+
+
+! precision not enough ?
+ IF ((work/=fine) .AND. (work/=abort)) GO TO 10
+! at "work=ABORT", we can startup with a new [r^]
+
+!$OMP end parallel
+
+! ###################### not parallel Code !!! #########################
+! compute [x]
+! [x] = (D+U)^(-1) * [x^]
+ CALL du(n_i,n_j,n_k,x,x,md,me,mf,mg)
+! ################### above not parallel Code !!! ######################
+
+ DEALLOCATE(rpar)
+
+!**************************************************************
+
+
+ RETURN
+ END
diff --git a/solve/omp_mvp.f90 b/solve/omp_mvp.f90
new file mode 100644
index 0000000..bd676fb
--- /dev/null
+++ b/solve/omp_mvp.f90
@@ -0,0 +1,345 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief apply 7point-star matrix multiply [as]:=[M]x[s], (OpenMP version)
+!> @param[in] N_I lengths of I dimension of local matrix [M]
+!> @param[in] N_J lengths of J dimension of local matrix [M]
+!> @param[in] N_K lengths of K dimension of local matrix [M]
+!> @param[in] s vector [s]
+!> @param[out] as vector [as]
+!> @param[in] A 1. diagonal of the system matrix [M]
+!> @param[in] B 2. diagonal of the system matrix [M]
+!> @param[in] C 3. diagonal of the system matrix [M]
+!> @param[in] D 4. (main) diagonal of the system matrix [M]
+!> @param[in] E 5. diagonal of the system matrix [M]
+!> @param[in] F 6. diagonal of the system matrix [M]
+!> @param[in] G 7. diagonal of the system matrix [M]
+!> @details
+!> OpenMP parallelised, general version - no special blocking\n
+!> apply 7point-star matrix multiply\n
+!> compute [as]:=[M]x[s], [s],[as],[M] given in 3-D-structure\n
+!> Data-Cube :\n
+!> @image html cube.png
+! k * * * *
+! / * * *
+! 0 -j * * * * *
+! | * * *
+! i * * *
+! * * * *
+ SUBROUTINE omp_mvp(n_i,n_j,n_k,s,as,a,b,c,d,e,f,g)
+ use mod_OMP_TOOLS
+ use mod_blocking_size
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+
+ INTEGER n_i, n_j, n_k
+! use mod_blocking_size
+
+ DOUBLE PRECISION s(*), as(*)
+ DOUBLE PRECISION a(*), b(*), c(*), d(*), e(*), f(*), g(*)
+
+ INTEGER pim, pip, pjm, pjp, pkm, pkp
+ INTEGER aim, aip, ajm, ajp, akm, akp
+ INTEGER bm, pm, pmb, am, pmmax
+
+! thread stuff
+ INTEGER tpos, tanz
+
+
+ tpos = 1
+ tanz = n_i*n_j*n_k
+!$ call OMP_PART(N_I*N_J*N_K,tpos,tanz)
+
+ bm = tpos + tanz - 1
+ pm = tpos
+ pmmax = n_i*n_j*n_k + 1
+
+
+! not ready yet, should modify for better performance !
+! +2.5% for '/27'
+ pmb = min(pm+int(bl_size/bldiv_mvp),bm+1)
+ am = pmb - pm
+
+! I-dim
+ pim = max(pm-1,1)
+ aim = pmb - 1 - pim
+ pip = min(pmb+1,pmmax)
+ aip = pip - 1 - pm
+
+! J-dim
+ pjm = max(pm-n_i,1)
+ ajm = pmb - n_i - pjm
+ pjp = min(pmb+n_i,pmmax)
+ ajp = pjp - n_i - pm
+
+! K-dim
+ pkm = max(pm-n_i*n_j,1)
+ akm = pmb - n_i*n_j - pkm
+ pkp = min(pmb+n_i*n_j,pmmax)
+ akp = pkp - n_i*n_j - pm
+
+100 CONTINUE
+
+ CALL dxyz(am,s(pm),d(pm),as(pm))
+!AW C$OMP barrier
+
+ IF (n_i>1) THEN
+ CALL dxypz(aip,s(pm+1),e(pm),as(pm))
+!AW C$OMP barrier
+ END IF
+ IF (n_j>1) THEN
+ CALL dxypz(ajp,s(pm+n_i),f(pm),as(pm))
+!AW C$OMP barrier
+ END IF
+ IF (n_k>1) THEN
+ CALL dxypz(akp,s(pm+n_i*n_j),g(pm),as(pm))
+!AW C$OMP barrier
+ END IF
+
+ IF (n_i>1) THEN
+ CALL dxypz(aim,s(pim),c(pim+1),as(pim+1))
+!AW C$OMP barrier
+ END IF
+ IF (n_j>1) THEN
+ CALL dxypz(ajm,s(pjm),b(pjm+n_i),as(pjm+n_i))
+!AW C$OMP barrier
+ END IF
+ IF (n_k>1) THEN
+ CALL dxypz(akm,s(pkm),a(pkm+n_i*n_j),as(pkm+n_i*n_j))
+!AW C$OMP barrier
+ END IF
+
+!aw write(*,*)' ',OMP_GET_HIS_THREAD_NUM(),pm,pm+am-1,pmb-1
+!aw write(*,*)'iC',OMP_GET_HIS_THREAD_NUM(),pim+1,-1,aim
+!aw write(*,*)'iE',OMP_GET_HIS_THREAD_NUM(),pm,1,aip
+!aw write(*,*)'jB',OMP_GET_HIS_THREAD_NUM(),pjm+N_I,-N_I,ajm
+!aw write(*,*)'jF',OMP_GET_HIS_THREAD_NUM(),pm,N_I,ajp
+!aw write(*,*)'kA',OMP_GET_HIS_THREAD_NUM(),pkm+N_I*N_J,-N_I*N_J,akm
+!aw write(*,*)'kG',OMP_GET_HIS_THREAD_NUM(),pm,N_I*N_J,akp
+
+ pm = pmb
+ pmb = min(pm+int(bl_size/bldiv_mvp),bm+1)
+ am = pmb - pm
+
+! I-dim
+ pim = max(pm-1,1)
+ aim = pmb - 1 - pim
+ pip = min(pmb+1,pmmax)
+ aip = pip - 1 - pm
+
+! J-dim
+ pjm = max(pm-n_i,1)
+ ajm = pmb - n_i - pjm
+ pjp = min(pmb+n_i,pmmax)
+ ajp = pjp - n_i - pm
+
+! K-dim
+ pkm = max(pm-n_i*n_j,1)
+ akm = pmb - n_i*n_j - pkm
+ pkp = min(pmb+n_i*n_j,pmmax)
+ akp = pkp - n_i*n_j - pm
+
+ IF (am>0) GO TO 100
+
+!$OMP barrier
+! need barrier here
+
+ RETURN
+ END
+
+!> @brief apply 7point-star matrix multiply [as]:=[M]x[s], serial (no OpenMP) implementation
+!> @param[in] N_I lengths of I dimension of local matrix [M]
+!> @param[in] N_J lengths of J dimension of local matrix [M]
+!> @param[in] N_K lengths of K dimension of local matrix [M]
+!> @param[in] s vector [s]
+!> @param[out] as vector [as]
+!> @param[in] A 1. diagonal of the system matrix [M]
+!> @param[in] B 2. diagonal of the system matrix [M]
+!> @param[in] C 3. diagonal of the system matrix [M]
+!> @param[in] D 4. (main) diagonal of the system matrix [M]
+!> @param[in] E 5. diagonal of the system matrix [M]
+!> @param[in] F 6. diagonal of the system matrix [M]
+!> @param[in] G 7. diagonal of the system matrix [M]
+!> @details
+!> serial (not OpenMP parallelised), general version - no special blocking\n
+!> apply 7point-star matrix multiply\n
+!> compute [as]:=[M]x[s], [s],[as],[M] given in 3-D-structure\n
+!> Data-Cube :\n
+!> @image html cube.png
+! k * * * *
+! / * * *
+! 0 -j * * * * *
+! | * * *
+! i * * *
+! * * * *
+ SUBROUTINE s_mvp(n_i,n_j,n_k,s,as,a,b,c,d,e,f,g)
+ use mod_blocking_size
+ IMPLICIT NONE
+
+ INTEGER n_i, n_j, n_k
+! use mod_blocking_size
+
+ DOUBLE PRECISION s(*), as(*)
+ DOUBLE PRECISION a(*), b(*), c(*), d(*), e(*), f(*), g(*)
+
+ INTEGER pim, pip, pjm, pjp, pkm, pkp
+ INTEGER aim, aip, ajm, ajp, akm, akp
+ INTEGER bm, pm, pmb, am, pmmax
+
+! thread stuff (disabled here)
+ INTEGER tpos, tanz
+
+
+ tpos = 1
+ tanz = n_i*n_j*n_k
+
+ bm = tpos + tanz - 1
+ pm = tpos
+ pmmax = n_i*n_j*n_k + 1
+
+! not ready yet, should modify for better performance !
+! +2.5% for '/27'
+ pmb = min(pm+int(bl_size/bldiv_mvp),bm+1)
+ am = pmb - pm
+
+! I-dim
+ pim = max(pm-1,1)
+ aim = pmb - 1 - pim
+ pip = min(pmb+1,pmmax)
+ aip = pip - 1 - pm
+
+! J-dim
+ pjm = max(pm-n_i,1)
+ ajm = pmb - n_i - pjm
+ pjp = min(pmb+n_i,pmmax)
+ ajp = pjp - n_i - pm
+
+! K-dim
+ pkm = max(pm-n_i*n_j,1)
+ akm = pmb - n_i*n_j - pkm
+ pkp = min(pmb+n_i*n_j,pmmax)
+ akp = pkp - n_i*n_j - pm
+
+100 CONTINUE
+
+ CALL dxyz(am,s(pm),d(pm),as(pm))
+
+ IF (n_i>1) THEN
+ CALL dxypz(aip,s(pm+1),e(pm),as(pm))
+ END IF
+ IF (n_j>1) THEN
+ CALL dxypz(ajp,s(pm+n_i),f(pm),as(pm))
+ END IF
+ IF (n_k>1) THEN
+ CALL dxypz(akp,s(pm+n_i*n_j),g(pm),as(pm))
+ END IF
+
+ IF (n_i>1) THEN
+ CALL dxypz(aim,s(pim),c(pim+1),as(pim+1))
+ END IF
+ IF (n_j>1) THEN
+ CALL dxypz(ajm,s(pjm),b(pjm+n_i),as(pjm+n_i))
+ END IF
+ IF (n_k>1) THEN
+ CALL dxypz(akm,s(pkm),a(pkm+n_i*n_j),as(pkm+n_i*n_j))
+ END IF
+
+ pm = pmb
+ pmb = min(pm+int(bl_size/bldiv_mvp),bm+1)
+ am = pmb - pm
+
+! I-dim
+ pim = max(pm-1,1)
+ aim = pmb - 1 - pim
+ pip = min(pmb+1,pmmax)
+ aip = pip - 1 - pm
+
+! J-dim
+ pjm = max(pm-n_i,1)
+ ajm = pmb - n_i - pjm
+ pjp = min(pmb+n_i,pmmax)
+ ajp = pjp - n_i - pm
+
+! K-dim
+ pkm = max(pm-n_i*n_j,1)
+ akm = pmb - n_i*n_j - pkm
+ pkp = min(pmb+n_i*n_j,pmmax)
+ akp = pkp - n_i*n_j - pm
+
+ IF (am>0) GO TO 100
+
+ RETURN
+ END
+
+!> @brief BLAS adapting : z=z+x*y
+!> @param[in] N length of vectors [z],[x],[y]
+!> @param[in] x vector [x]
+!> @param[in] y vector [y]
+!> @param[in] z vector [z]
+!> @param[out] z vector [z]
+ SUBROUTINE dxypz(n,x,y,z)
+ IMPLICIT NONE
+ INTEGER n, i, m
+ DOUBLE PRECISION x(n), y(n), z(n)
+
+ m = mod(n,4)
+ DO i = 1, m
+ z(i) = z(i) + x(i)*y(i)
+ END DO
+
+ m = m + 1
+ DO i = m, n, 4
+ z(i+0) = z(i+0) + x(i+0)*y(i+0)
+ z(i+1) = z(i+1) + x(i+1)*y(i+1)
+ z(i+2) = z(i+2) + x(i+2)*y(i+2)
+ z(i+3) = z(i+3) + x(i+3)*y(i+3)
+ END DO
+
+ RETURN
+ END
+
+
+!> @brief BLAS adapting : z=x*y
+!> @param[in] N length of vectors [z],[x],[y]
+!> @param[in] x vector [x]
+!> @param[in] y vector [y]
+!> @param[out] z vector [z]
+ SUBROUTINE dxyz(n,x,y,z)
+ IMPLICIT NONE
+ INTEGER n, i, m
+ DOUBLE PRECISION x(n), y(n), z(n)
+
+ m = mod(n,4)
+ DO i = 1, m
+ z(i) = x(i)*y(i)
+ END DO
+
+ m = m + 1
+ DO i = m, n, 4
+ z(i+0) = x(i+0)*y(i+0)
+ z(i+1) = x(i+1)*y(i+1)
+ z(i+2) = x(i+2)*y(i+2)
+ z(i+3) = x(i+3)*y(i+3)
+ END DO
+
+ RETURN
+ END
diff --git a/solve/omp_mvp2.f90 b/solve/omp_mvp2.f90
new file mode 100644
index 0000000..adb4f82
--- /dev/null
+++ b/solve/omp_mvp2.f90
@@ -0,0 +1,418 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief apply thread local 7point-star matrix multiply [as]:=[M]x[s], (OpenMP version)
+!> @param[in] N_I lengths of I dimension of local matrix [M]
+!> @param[in] N_J lengths of J dimension of local matrix [M]
+!> @param[in] N_K lengths of K dimension of local matrix [M]
+!> @param[in] lxyz_block number of blocks
+!> @param[in] xloc thread local blocks of the vector [s]
+!> @param[out] Mxloc thread local blocks of the vector [as]
+!> @param[in] LMA thread local blocks of the 1. diagonal of the system matrix [M]
+!> @param[in] LMB thread local blocks of the 2. diagonal of the system matrix [M]
+!> @param[in] LMC thread local blocks of the 3. diagonal of the system matrix [M]
+!> @param[in] LMD thread local blocks of the 4. (main) diagonal of the system matrix [M]
+!> @param[in] LME thread local blocks of the 5. diagonal of the system matrix [M]
+!> @param[in] LMF thread local blocks of the 6. diagonal of the system matrix [M]
+!> @param[in] LMG thread local blocks of the 7. diagonal of the system matrix [M]
+!> @param[in] xyz_block block dimensions
+!> @param[in] bound_block boundary exchange buffer for each block, between the threads
+!> @details
+!> OpenMP parallelised with special blocking\n
+ SUBROUTINE omp_mvp2(n_i,n_j,n_k,lxyz_block,xloc,mxloc,lma,lmb, &
+ lmc,lmd,lme,lmf,lmg,bound_block,xyz_block)
+ use mod_OMP_TOOLS
+ use mod_blocking_size
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+
+! N : length of all vectors r,z
+ INTEGER n_i, n_j, n_k
+ INTEGER k_e, j_e, i_e
+ INTEGER ii
+ INTEGER xi, yi, zi
+ INTEGER xip1, yip1, zip1, xim1, yim1, zim1
+
+! use mod_blocking_size
+
+ INTEGER lxyz_block, xyz_block(3,lxyz_block)
+ DOUBLE PRECISION lme(block_i*block_j*block_k,lxyz_block)
+ DOUBLE PRECISION lmf(block_i*block_j*block_k,lxyz_block)
+ DOUBLE PRECISION lmg(block_i*block_j*block_k,lxyz_block)
+ DOUBLE PRECISION lmb(block_i*block_j*block_k,lxyz_block)
+ DOUBLE PRECISION lmc(block_i*block_j*block_k,lxyz_block)
+ DOUBLE PRECISION lmd(block_i*block_j*block_k,lxyz_block)
+ DOUBLE PRECISION lma(block_i*block_j*block_k,lxyz_block)
+ DOUBLE PRECISION xloc(block_i*block_j*block_k,lxyz_block)
+ DOUBLE PRECISION mxloc(block_i*block_j*block_k,lxyz_block)
+! global boundary buffer [x]
+ DOUBLE PRECISION bound_block(block_i*block_j+block_i*block_k+ &
+ block_j*block_k,bdim_i,bdim_j,bdim_k,2)
+
+ INTEGER isurf, ijsurf, ijksurf
+
+
+! surface offset: 1=I-dim, isurf=J-dim, ijsurf=K-dim
+ isurf = block_j*block_k + 1
+ ijsurf = isurf + block_i*block_k
+ ijksurf = block_j*block_k + block_i*block_k + block_i*block_j
+! -----------------------------------------------------------------
+
+! exchange boundaries of all blocks
+ DO ii = 1, lxyz_block
+ xi = xyz_block(1,ii)
+ yi = xyz_block(2,ii)
+ zi = xyz_block(3,ii)
+! compute begin & end
+ i_e = min(block_i,n_i-((xi-1)*block_i))
+ j_e = min(block_j,n_j-((yi-1)*block_j))
+ k_e = min(block_k,n_k-((zi-1)*block_k))
+! block index dim-1
+ xim1 = max(xi-1,1)
+ yim1 = max(yi-1,1)
+ zim1 = max(zi-1,1)
+! block index dim+1
+ xip1 = min(xi+1,bdim_i)
+ yip1 = min(yi+1,bdim_j)
+ zip1 = min(zi+1,bdim_k)
+
+ CALL exchange_xloc(block_i,block_j,block_k,i_e,j_e,k_e, &
+ xloc(1,ii),bound_block(1,xim1,yi,zi,2), &
+ bound_block(isurf,xi,yim1,zi,2),bound_block(ijsurf,xi,yi, &
+ zim1,2),bound_block(1,xip1,yi,zi,1), &
+ bound_block(isurf,xi,yip1,zi,1),bound_block(ijsurf,xi,yi, &
+ zip1,1),bound_block(1,xi,yi,zi,1), &
+ bound_block(isurf,xi,yi,zi,1),bound_block(ijsurf,xi,yi,zi, &
+ 1),bound_block(1,xi,yi,zi,2),bound_block(isurf,xi,yi,zi,2) &
+ ,bound_block(ijsurf,xi,yi,zi,2),xim1-xi+1,yim1-yi+1, &
+ zim1-zi+1,xip1-xi-1,yip1-yi-1,zip1-zi-1)
+ END DO
+
+!$OMP barrier
+! MVP of all blocks
+ DO ii = 1, lxyz_block
+ xi = xyz_block(1,ii)
+ yi = xyz_block(2,ii)
+ zi = xyz_block(3,ii)
+! compute begin & end
+ i_e = min(block_i,n_i-((xi-1)*block_i))
+ j_e = min(block_j,n_j-((yi-1)*block_j))
+ k_e = min(block_k,n_k-((zi-1)*block_k))
+
+ CALL mvp_xloc(block_i,block_j,block_k,i_e,j_e,k_e, &
+ xloc(1,ii),mxloc(1,ii),lma(1,ii),lmb(1,ii),lmc(1,ii), &
+ lmd(1,ii),lme(1,ii),lmf(1,ii),lmg(1,ii), &
+ bound_block(1,xi,yi,zi,1),bound_block(isurf,xi,yi,zi,1), &
+ bound_block(ijsurf,xi,yi,zi,1),bound_block(1,xi,yi,zi,2), &
+ bound_block(isurf,xi,yi,zi,2),bound_block(ijsurf,xi,yi,zi, &
+ 2))
+ END DO
+
+ RETURN
+ END
+
+!> @brief exchange boundary for the [xloc] block
+!> @param[in] ldI leading dimensions in I direction
+!> @param[in] ldJ leading dimensions in J direction
+!> @param[in] ldK leading dimensions in K direction
+!> @param[in] i_e block size in I direction
+!> @param[in] j_e block size in J direction
+!> @param[in] k_e block size in K direction
+!> @param[out] xloc_im1 global boundary buffer to the -1 neighbour in I direction
+!> @param[out] xloc_jm1 global boundary buffer to the -1 neighbour in J direction
+!> @param[out] xloc_km1 global boundary buffer to the -1 neighbour in K direction
+!> @param[out] xloc_ip1 global boundary buffer to the +1 neighbour in I direction
+!> @param[out] xloc_jp1 global boundary buffer to the +1 neighbour in J direction
+!> @param[out] xloc_kp1 global boundary buffer to the +1 neighbour in K direction
+!> @param[out] sxloc_im1 (self) own boundary buffer from the -1 neighbour in I direction
+!> @param[out] sxloc_jm1 (self) own boundary buffer from the -1 neighbour in J direction
+!> @param[out] sxloc_km1 (self) own boundary buffer from the -1 neighbour in K direction
+!> @param[out] sxloc_ip1 (self) own boundary buffer from the +1 neighbour in I direction
+!> @param[out] sxloc_jp1 (self) own boundary buffer from the +1 neighbour in J direction
+!> @param[out] sxloc_kp1 (self) own boundary buffer from the +1 neighbour in K direction
+!> @param[in] cmi 0: copy boundary to the -1 neighbour in I direction, <>0: clear local buffer
+!> @param[in] cmj 0: copy boundary to the -1 neighbour in J direction, <>0: clear local buffer
+!> @param[in] cmk 0: copy boundary to the -1 neighbour in K direction, <>0: clear local buffer
+!> @param[in] cpi 0: copy boundary to the +1 neighbour in I direction, <>0: clear local buffer
+!> @param[in] cpj 0: copy boundary to the +1 neighbour in J direction, <>0: clear local buffer
+!> @param[in] cpk 0: copy boundary to the +1 neighbour in K direction, <>0: clear local buffer
+!> @param[in] xloc local block (elements)
+ SUBROUTINE exchange_xloc(ldi,ldj,ldk,i_e,j_e,k_e,xloc,xloc_im1, &
+ xloc_jm1,xloc_km1,xloc_ip1,xloc_jp1,xloc_kp1,sxloc_im1, &
+ sxloc_jm1,sxloc_km1,sxloc_ip1,sxloc_jp1,sxloc_kp1,cmi,cmj, &
+ cmk,cpi,cpj,cpk)
+ use mod_OMP_TOOLS
+ use mod_blocking_size
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+! N : length of all vectors r,z
+ INTEGER i_e, j_e, k_e, i, j, k, ldi, ldj, ldk
+ INTEGER cmi, cmj, cmk, cpi, cpj, cpk
+! vectors [r], [z]
+ DOUBLE PRECISION xloc(ldi,ldj,ldk)
+
+! use mod_blocking_size
+! global boundary buffer
+ DOUBLE PRECISION xloc_im1(block_j,block_k)
+ DOUBLE PRECISION xloc_jm1(block_i,block_k)
+ DOUBLE PRECISION xloc_km1(block_i,block_j)
+ DOUBLE PRECISION xloc_ip1(block_j,block_k)
+ DOUBLE PRECISION xloc_jp1(block_i,block_k)
+ DOUBLE PRECISION xloc_kp1(block_i,block_j)
+! (self) owner of this bloCk
+ DOUBLE PRECISION sxloc_im1(block_j,block_k)
+ DOUBLE PRECISION sxloc_jm1(block_i,block_k)
+ DOUBLE PRECISION sxloc_km1(block_i,block_j)
+ DOUBLE PRECISION sxloc_ip1(block_j,block_k)
+ DOUBLE PRECISION sxloc_jp1(block_i,block_k)
+ DOUBLE PRECISION sxloc_kp1(block_i,block_j)
+
+! boundary exchange
+! [2D-I]
+ IF (cmi==0) THEN
+ DO k = 1, k_e
+ DO j = 1, j_e
+ xloc_im1(j,k) = xloc(1,j,k)
+ END DO
+ END DO
+ ELSE
+! own buffer
+ DO k = 1, k_e
+ DO j = 1, j_e
+ sxloc_im1(j,k) = 0.0D0
+ END DO
+ END DO
+ END IF
+ IF (cpi==0) THEN
+ DO k = 1, k_e
+ DO j = 1, j_e
+ xloc_ip1(j,k) = xloc(i_e,j,k)
+ END DO
+ END DO
+ ELSE
+! own buffer
+ DO k = 1, k_e
+ DO j = 1, j_e
+ sxloc_ip1(j,k) = 0.0D0
+ END DO
+ END DO
+ END IF
+
+! [2D-J]
+ IF (cmj==0) THEN
+ DO k = 1, k_e
+ DO i = 1, i_e
+ xloc_jm1(i,k) = xloc(i,1,k)
+ END DO
+ END DO
+ ELSE
+! own buffer
+ DO k = 1, k_e
+ DO i = 1, i_e
+ sxloc_jm1(i,k) = 0.0D0
+ END DO
+ END DO
+ END IF
+ IF (cpj==0) THEN
+ DO k = 1, k_e
+ DO i = 1, i_e
+ xloc_jp1(i,k) = xloc(i,j_e,k)
+ END DO
+ END DO
+ ELSE
+! own buffer
+ DO k = 1, k_e
+ DO i = 1, i_e
+ sxloc_jp1(i,k) = 0.0D0
+ END DO
+ END DO
+ END IF
+
+! [2D-K]
+ IF (cmk==0) THEN
+ DO j = 1, j_e
+ DO i = 1, i_e
+ xloc_km1(i,j) = xloc(i,j,1)
+ END DO
+ END DO
+ ELSE
+! own buffer
+ DO j = 1, j_e
+ DO i = 1, i_e
+ sxloc_km1(i,j) = 0.0D0
+ END DO
+ END DO
+ END IF
+ IF (cpk==0) THEN
+ DO j = 1, j_e
+ DO i = 1, i_e
+ xloc_kp1(i,j) = xloc(i,j,k_e)
+ END DO
+ END DO
+ ELSE
+! own buffer
+ DO j = 1, j_e
+ DO i = 1, i_e
+ sxloc_kp1(i,j) = 0.0D0
+ END DO
+ END DO
+ END IF
+
+ RETURN
+ END
+
+!> @brief thread local block matrix vector product [as]:=[M]x[s], one single block
+!> @param[in] ldI leading dimensions in I direction
+!> @param[in] ldJ leading dimensions in J direction
+!> @param[in] ldK leading dimensions in K direction
+!> @param[in] i_e block size in I direction
+!> @param[in] j_e block size in J direction
+!> @param[in] k_e block size in K direction
+!> @param[in] xloc local block (elements) - thread local part of vector [s]
+!> @param[out] Mxloc result vector - thread local part of vector [as]
+!> @param[in] MA thread local blocks of the 1. diagonal of the system matrix [M]
+!> @param[in] MB thread local blocks of the 2. diagonal of the system matrix [M]
+!> @param[in] MC thread local blocks of the 3. diagonal of the system matrix [M]
+!> @param[in] MD thread local blocks of the 4. (main) diagonal of the system matrix [M]
+!> @param[in] ME thread local blocks of the 5. diagonal of the system matrix [M]
+!> @param[in] MF thread local blocks of the 6. diagonal of the system matrix [M]
+!> @param[in] MG thread local blocks of the 7. diagonal of the system matrix [M]
+!> @param[in] xloc_im1 global boundary buffer from the -1 neighbour in I direction
+!> @param[in] xloc_jm1 global boundary buffer from the -1 neighbour in J direction
+!> @param[in] xloc_km1 global boundary buffer from the -1 neighbour in K direction
+!> @param[in] xloc_ip1 global boundary buffer from the +1 neighbour in I direction
+!> @param[in] xloc_jp1 global boundary buffer from the +1 neighbour in J direction
+!> @param[in] xloc_kp1 global boundary buffer from the +1 neighbour in K direction
+ SUBROUTINE mvp_xloc(ldi,ldj,ldk,i_e,j_e,k_e,xloc,mxloc,ma,mb,mc, &
+ md,me,mf,mg,xloc_im1,xloc_jm1,xloc_km1,xloc_ip1,xloc_jp1, &
+ xloc_kp1)
+ use mod_OMP_TOOLS
+ use mod_blocking_size
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+
+! N : length of all vectors r,z
+ INTEGER i_e, j_e, k_e, i, j, k, ldi, ldj, ldk
+! vectors [r], [z]
+ DOUBLE PRECISION xloc(ldi,ldj,ldk), mxloc(ldi,ldj,ldk)
+ DOUBLE PRECISION ma(ldi,ldj,ldk), mb(ldi,ldj,ldk)
+ DOUBLE PRECISION mc(ldi,ldj,ldk), md(ldi,ldj,ldk)
+ DOUBLE PRECISION me(ldi,ldj,ldk), mf(ldi,ldj,ldk)
+ DOUBLE PRECISION mg(ldi,ldj,ldk)
+
+! use mod_blocking_size
+! global boundary buffer
+ DOUBLE PRECISION xloc_im1(block_j,block_k)
+ DOUBLE PRECISION xloc_jm1(block_i,block_k)
+ DOUBLE PRECISION xloc_km1(block_i,block_j)
+ DOUBLE PRECISION xloc_ip1(block_j,block_k)
+ DOUBLE PRECISION xloc_jp1(block_i,block_k)
+ DOUBLE PRECISION xloc_kp1(block_i,block_j)
+
+! [I] direction
+ i = 1
+ DO k = 1, k_e
+ DO j = 1, j_e
+ mxloc(i,j,k) = md(i,j,k)*xloc(i,j,k) + &
+ mc(i,j,k)*xloc_im1(j,k)
+ END DO
+ END DO
+ DO k = 1, k_e
+ DO j = 1, j_e
+ DO i = 2, i_e
+ mxloc(i,j,k) = md(i,j,k)*xloc(i,j,k) + &
+ mc(i,j,k)*xloc(i-1,j,k)
+ END DO
+ END DO
+ END DO
+ i = i_e
+ DO k = 1, k_e
+ DO j = 1, j_e
+ mxloc(i,j,k) = mxloc(i,j,k) + me(i,j,k)*xloc_ip1(j,k)
+ END DO
+ END DO
+ DO k = 1, k_e
+ DO j = 1, j_e
+ DO i = 1, i_e - 1
+ mxloc(i,j,k) = mxloc(i,j,k) + me(i,j,k)*xloc(i+1,j,k)
+ END DO
+ END DO
+ END DO
+
+! [J] direction
+ j = 1
+ DO k = 1, k_e
+ DO i = 1, i_e
+ mxloc(i,j,k) = mxloc(i,j,k) + mb(i,j,k)*xloc_jm1(i,k)
+ END DO
+ END DO
+ DO k = 1, k_e
+ DO j = 2, j_e
+ DO i = 1, i_e
+ mxloc(i,j,k) = mxloc(i,j,k) + mb(i,j,k)*xloc(i,j-1,k)
+ END DO
+ END DO
+ END DO
+ j = j_e
+ DO k = 1, k_e
+ DO i = 1, i_e
+ mxloc(i,j,k) = mxloc(i,j,k) + mf(i,j,k)*xloc_jp1(i,k)
+ END DO
+ END DO
+ DO k = 1, k_e
+ DO j = 1, j_e - 1
+ DO i = 1, i_e
+ mxloc(i,j,k) = mxloc(i,j,k) + mf(i,j,k)*xloc(i,j+1,k)
+ END DO
+ END DO
+ END DO
+
+! [K] direction
+ k = 1
+ DO j = 1, j_e
+ DO i = 1, i_e
+ mxloc(i,j,k) = mxloc(i,j,k) + ma(i,j,k)*xloc_km1(i,j)
+ END DO
+ END DO
+ DO k = 2, k_e
+ DO j = 1, j_e
+ DO i = 1, i_e
+ mxloc(i,j,k) = mxloc(i,j,k) + ma(i,j,k)*xloc(i,j,k-1)
+ END DO
+ END DO
+ END DO
+ k = k_e
+ DO j = 1, j_e
+ DO i = 1, i_e
+ mxloc(i,j,k) = mxloc(i,j,k) + mg(i,j,k)*xloc_kp1(i,j)
+ END DO
+ END DO
+ DO k = 1, k_e - 1
+ DO j = 1, j_e
+ DO i = 1, i_e
+ mxloc(i,j,k) = mxloc(i,j,k) + mg(i,j,k)*xloc(i,j,k+1)
+ END DO
+ END DO
+ END DO
+
+ RETURN
+ END
diff --git a/solve/omp_preconditioners.f90 b/solve/omp_preconditioners.f90
new file mode 100644
index 0000000..1253d51
--- /dev/null
+++ b/solve/omp_preconditioners.f90
@@ -0,0 +1,1100 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief ILU(0) preconditioner, solving block-based [L][U] x [x] = [b], (OpenMP version)
+!> @param[in] N_I lengths of I dimension of local matrix [M]~[L][U]
+!> @param[in] N_J lengths of J dimension of local matrix [M]~[L][U]
+!> @param[in] N_K lengths of K dimension of local matrix [M]~[L][U]
+!> @param[in] lxyz_block number of blocks
+!> @param[in] bloc thread local blocks of vector [b]
+!> @param[out] xloc thread local blocks of vector [x]
+!> @param[in] lMA thread local blocks of the 1. diagonal of [L]
+!> @param[in] lMB thread local blocks of the 2. diagonal of [L]
+!> @param[in] lMC thread local blocks of the 3. diagonal of [L]
+!> @param[in] lUD thread local blocks of the helper diagonal [UD] of [L] and [U]
+!> @param[in] lME thread local blocks of the 2. diagonal of [U]
+!> @param[in] lMF thread local blocks of the 3. diagonal of [U]
+!> @param[in] lMG thread local blocks of the 4. diagonal of [U]
+!> @param[out] ud_block block buffer for helper diagonal [UD]
+!> @param[out] bound_block boundary exchange buffer for each block, between the threads
+!> @param[in] xyz_block block dimensions
+!> @param[in,out] ProzA_lock locks to mark alreads computed blocks
+ SUBROUTINE omp_lu_solve2(n_i,n_j,n_k,lxyz_block,bloc,xloc,lma, &
+ lmb,lmc,lud,lme,lmf,lmg,ud_block,bound_block,xyz_block, &
+ proza_lock)
+ use arrays
+ use mod_OMP_TOOLS
+ use mod_blocking_size
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+! N : length of all vectors r,z
+ INTEGER n_i, n_j, n_k
+ INTEGER k_e, j_e, i_e
+ INTEGER ii, jj, kk, ll
+ INTEGER xi, yi, zi
+ INTEGER xip1, yip1, zip1, xim1, yim1, zim1
+! use mod_blocking_size
+ INTEGER lxyz_block, xyz_block(3,lxyz_block)
+ DOUBLE PRECISION lme(block_i*block_j*block_k,lxyz_block)
+ DOUBLE PRECISION lmf(block_i*block_j*block_k,lxyz_block)
+ DOUBLE PRECISION lmg(block_i*block_j*block_k,lxyz_block)
+ DOUBLE PRECISION lmb(block_i*block_j*block_k,lxyz_block)
+ DOUBLE PRECISION lmc(block_i*block_j*block_k,lxyz_block)
+ DOUBLE PRECISION lud(block_i*block_j*block_k,lxyz_block)
+ DOUBLE PRECISION lma(block_i*block_j*block_k,lxyz_block)
+ DOUBLE PRECISION bloc(block_i*block_j*block_k,lxyz_block)
+ DOUBLE PRECISION xloc(block_i*block_j*block_k,lxyz_block)
+! [UD] surface on position-1
+ DOUBLE PRECISION ud_block(block_i*block_j+block_i*block_k+ &
+ block_j*block_k,lxyz_block)
+! global boundary buffer [x]
+ DOUBLE PRECISION bound_block(block_i*block_j+block_i*block_k+ &
+ block_j*block_k,bdim_i,bdim_j,bdim_k)
+
+ INTEGER proza_lock(bdim_i*bdim_j*bdim_k)
+ INTEGER par_name, isurf, ijsurf, ijksurf
+ EXTERNAL par_name
+
+
+! surface offset: 1=I-dim, isurf=J-dim, ijsurf=K-dim
+ isurf = block_j*block_k + 1
+ ijsurf = isurf + block_i*block_k
+ ijksurf = block_j*block_k + block_i*block_k + block_i*block_j
+! -----------------------------------------------------------------
+
+! over all local blocks
+ DO ii = 1, lxyz_block
+! 'jj' is the linear block index corresponding [xi,yi,zi]
+100 DO jj = 1, lxyz_block
+ kk = 0
+ xi = xyz_block(1,jj)
+ yi = xyz_block(2,jj)
+ zi = xyz_block(3,jj)
+! [i,j,k]-index
+ ll = xi + bdim_i*(yi-1) + bdim_i*bdim_j*(zi-1)
+! search for locked blocks (needs to be computed)
+ IF (par_name(proza_lock(ll))==0) THEN
+! search for unlocked blocks (already computed)
+! test [i-1,j,k]
+ IF (xi>1) THEN
+! [i-1,j,k]-index
+ xip1 = ll - 1
+ IF (par_name(proza_lock(xip1))==1) kk = kk + 1
+ ELSE
+ kk = kk + 1
+ END IF
+! test [i,j-1,k]
+ IF (yi>1) THEN
+! [i,j-1,k]-index
+ xip1 = ll - bdim_i
+ IF (par_name(proza_lock(xip1))==1) kk = kk + 1
+ ELSE
+ kk = kk + 1
+ END IF
+! test [i,j,k-1]
+ IF (zi>1) THEN
+! [i,j,k-1]-index
+ xip1 = ll - bdim_i*bdim_j
+ IF (par_name(proza_lock(xip1))==1) kk = kk + 1
+ ELSE
+ kk = kk + 1
+ END IF
+! can the block be computed ?
+ IF (kk==3) THEN
+! now: [xi,yi,zi] is the current computable block 'll', private 'jj'
+ GO TO 101
+ END IF
+ END IF
+ END DO
+! polling ... needs to found a free block
+ GO TO 100
+! found a computable block
+101 CONTINUE
+
+! compute begin & end
+ i_e = min(block_i,n_i-((xi-1)*block_i))
+ j_e = min(block_j,n_j-((yi-1)*block_j))
+ k_e = min(block_k,n_k-((zi-1)*block_k))
+! block index dim+1
+ xip1 = min(xi+1,bdim_i)
+ yip1 = min(yi+1,bdim_j)
+ zip1 = min(zi+1,bdim_k)
+
+! solve [L]x[t]=[b]
+ CALL flu_left2(block_i,block_j,block_k,i_e,j_e,k_e, &
+ bloc(1,jj),xloc(1,jj),lma(1,jj),lmb(1,jj),lmc(1,jj), &
+ lud(1,jj),bound_block(1,xi,yi,zi), &
+ bound_block(isurf,xi,yi,zi),bound_block(ijsurf,xi,yi,zi), &
+ bound_block(1,xip1,yi,zi),bound_block(isurf,xi,yip1,zi), &
+ bound_block(ijsurf,xi,yi,zip1),ud_block(1,jj), &
+ ud_block(isurf,jj),ud_block(ijsurf,jj),xip1-xi-1, &
+ yip1-yi-1,zip1-zi-1)
+
+ CALL par_disab(proza_lock(ll))
+
+ IF ((xi==bdim_i) .AND. (yi==bdim_j) .AND. (zi==bdim_k)) THEN
+ CALL par_reset(proza_lock)
+ CALL set_dval(ijksurf,0.D0,bound_block(1,xi,yi,zi))
+ END IF
+
+ END DO
+
+! -----------------------------------------------------------------
+
+! waiting for finishing L-step
+!$OMP barrier
+
+! -----------------------------------------------------------------
+
+! over all local blocks
+ DO ii = 1, lxyz_block
+! 'jj' is the linear block index corresponding [xi,yi,zi]
+200 DO jj = lxyz_block, 1, -1
+ kk = 0
+ xi = xyz_block(1,jj)
+ yi = xyz_block(2,jj)
+ zi = xyz_block(3,jj)
+! [i,j,k]-index
+ ll = xi + bdim_i*(yi-1) + bdim_i*bdim_j*(zi-1)
+! search for locked blocks (needs to be computed)
+ IF (par_name(proza_lock(ll))==0) THEN
+! search for unlocked blocks (already computed)
+! test [i+1,j,k]
+ IF (xi<bdim_i) THEN
+! [i+1,j,k]-index
+ xip1 = ll + 1
+ IF (par_name(proza_lock(xip1))==1) kk = kk + 1
+ ELSE
+ kk = kk + 1
+ END IF
+! test [i,j+1,k]
+ IF (yi<bdim_j) THEN
+! [i,j+1,k]-index
+ xip1 = ll + bdim_i
+ IF (par_name(proza_lock(xip1))==1) kk = kk + 1
+ ELSE
+ kk = kk + 1
+ END IF
+! test [i,j,k+1]
+ IF (zi<bdim_k) THEN
+! [i,j,k+1]-index
+ xip1 = ll + bdim_i*bdim_j
+ IF (par_name(proza_lock(xip1))==1) kk = kk + 1
+ ELSE
+ kk = kk + 1
+ END IF
+! can the block be computed ?
+ IF (kk==3) THEN
+! now: [xi,yi,zi] is the current computable block 'll', private 'jj'
+ GO TO 201
+ END IF
+ END IF
+ END DO
+! polling ... needs to found a free block
+ GO TO 200
+! found a computable block
+201 CONTINUE
+
+! compute begin & end
+ i_e = min(block_i,n_i-((xi-1)*block_i))
+ j_e = min(block_j,n_j-((yi-1)*block_j))
+ k_e = min(block_k,n_k-((zi-1)*block_k))
+! block index dim-1
+ xim1 = max(xi-1,1)
+ yim1 = max(yi-1,1)
+ zim1 = max(zi-1,1)
+
+! solve [U]x[t]=[b]
+ CALL flu_right2(block_i,block_j,block_k,i_e,j_e,k_e, &
+ xloc(1,jj),lud(1,jj),lme(1,jj),lmf(1,jj),lmg(1,jj), &
+ bound_block(1,xim1,yi,zi),bound_block(isurf,xi,yim1,zi), &
+ bound_block(ijsurf,xi,yi,zim1),bound_block(1,xi,yi,zi), &
+ bound_block(isurf,xi,yi,zi),bound_block(ijsurf,xi,yi,zi), &
+ xim1-xi+1,yim1-yi+1,zim1-zi+1)
+
+ CALL par_disab(proza_lock(ll))
+
+ IF ((xi==1) .AND. (yi==1) .AND. (zi==1)) THEN
+ CALL par_reset(proza_lock)
+ CALL set_dval(ijksurf,0.D0,bound_block(1,xi,yi,zi))
+ END IF
+
+ END DO
+
+! -----------------------------------------------------------------
+
+ RETURN
+ END
+
+!> @brief compute [L]-part by solving [L] x [t] = [b]
+!> @param[in] bloc vector [b]
+!> @param[in,out] xloc result vector [t]
+!> @param[in] UA thread local blocks of the 1. diagonal of [L]
+!> @param[in] UB thread local blocks of the 2. diagonal of [L]
+!> @param[in] UC thread local blocks of the 3. diagonal of [L]
+!> @param[in] UD thread local blocks of the helper diagonal [UD] of [L]
+!> @param[in] ldI leading dimensions in I direction
+!> @param[in] ldJ leading dimensions in J direction
+!> @param[in] ldK leading dimensions in K direction
+!> @param[in] i_e block size in I direction
+!> @param[in] j_e block size in J direction
+!> @param[in] k_e block size in K direction
+!> @param[in] xloc_im1 global boundary buffer from the -1 neighbour in I direction
+!> @param[in] xloc_jm1 global boundary buffer from the -1 neighbour in J direction
+!> @param[in] xloc_km1 global boundary buffer from the -1 neighbour in K direction
+!> @param[out] xloc_ip1 global boundary buffer to the +1 neighbour in I direction
+!> @param[out] xloc_jp1 global boundary buffer to the +1 neighbour in J direction
+!> @param[out] xloc_kp1 global boundary buffer to the +1 neighbour in K direction
+!> @param[in] UD_im1 local UD-buffer from the -1 neighbour in I direction
+!> @param[in] UD_jm1 local UD-buffer from the -1 neighbour in J direction
+!> @param[in] UD_km1 local UD-buffer from the -1 neighbour in K direction
+!> @param[in] ci 0: copy boundary values in [xloc_ip1], <>0: do nothing
+!> @param[in] cj 0: copy boundary values in [xloc_jp1], <>0: do nothing
+!> @param[in] ck 0: copy boundary values in [xloc_kp1], <>0: do nothing
+ SUBROUTINE flu_left2(ldi,ldj,ldk,i_e,j_e,k_e,bloc,xloc,ua,ub,uc, &
+ ud,xloc_im1,xloc_jm1,xloc_km1,xloc_ip1,xloc_jp1,xloc_kp1, &
+ ud_im1,ud_jm1,ud_km1,ci,cj,ck)
+ use mod_OMP_TOOLS
+ use mod_blocking_size
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+
+! N : length of all vectors r,z
+ INTEGER i_e, j_e, k_e, i, j, k, ldi, ldj, ldk, ci, cj, ck
+! vectors [r], [z]
+ DOUBLE PRECISION bloc(ldi,ldj,ldk), xloc(ldi,ldj,ldk)
+ DOUBLE PRECISION ua(ldi,ldj,ldk), ub(ldi,ldj,ldk)
+ DOUBLE PRECISION uc(ldi,ldj,ldk), ud(ldi,ldj,ldk)
+
+! use mod_blocking_size
+! global boundary buffer
+ DOUBLE PRECISION xloc_im1(block_j,block_k)
+ DOUBLE PRECISION xloc_jm1(block_i,block_k)
+ DOUBLE PRECISION xloc_km1(block_i,block_j)
+ DOUBLE PRECISION xloc_ip1(block_j,block_k)
+ DOUBLE PRECISION xloc_jp1(block_i,block_k)
+ DOUBLE PRECISION xloc_kp1(block_i,block_j)
+! local UD-buffer (-1)
+ DOUBLE PRECISION ud_im1(block_j,block_k)
+ DOUBLE PRECISION ud_jm1(block_i,block_k)
+ DOUBLE PRECISION ud_km1(block_i,block_j)
+
+!$OMP flush(xloc_im1, xloc_jm1, xloc_km1)
+
+! solve [L]x[t]=[b]
+! [0D]
+ xloc(1,1,1) = bloc(1,1,1) - uc(1,1,1)*ud_im1(1,1)*xloc_im1(1,1 &
+ ) - ub(1,1,1)*ud_jm1(1,1)*xloc_jm1(1,1) - &
+ ua(1,1,1)*ud_km1(1,1)*xloc_km1(1,1)
+
+
+! [1D-I]
+ DO i = 2, i_e
+ xloc(i,1,1) = bloc(i,1,1) - uc(i,1,1)*ud(i-1,1,1)*xloc(i-1,1 &
+ ,1) - ub(i,1,1)*ud_jm1(i,1)*xloc_jm1(i,1) - &
+ ua(i,1,1)*ud_km1(i,1)*xloc_km1(i,1)
+ END DO
+
+! [1D-J]
+ DO j = 2, j_e
+ xloc(1,j,1) = bloc(1,j,1) - uc(1,j,1)*ud_im1(j,1)*xloc_im1(j &
+ ,1) - ub(1,j,1)*ud(1,j-1,1)*xloc(1,j-1,1) - &
+ ua(1,j,1)*ud_km1(1,j)*xloc_km1(1,j)
+ END DO
+
+! [1D-K]
+ DO k = 2, k_e
+ xloc(1,1,k) = bloc(1,1,k) - uc(1,1,k)*ud_im1(1,k)*xloc_im1(1 &
+ ,k) - ub(1,1,k)*ud_jm1(1,k)*xloc_jm1(1,k) - &
+ ua(1,1,k)*ud(1,1,k-1)*xloc(1,1,k-1)
+ END DO
+
+
+! [2D-I]
+ DO k = 2, k_e
+ DO j = 2, j_e
+ xloc(1,j,k) = bloc(1,j,k) - uc(1,j,k)*ud_im1(j,k)*xloc_im1 &
+ (j,k) - ub(1,j,k)*ud(1,j-1,k)*xloc(1,j-1,k) - &
+ ua(1,j,k)*ud(1,j,k-1)*xloc(1,j,k-1)
+ END DO
+ END DO
+
+! [2D-J]
+ DO k = 2, k_e
+ DO i = 2, i_e
+ xloc(i,1,k) = bloc(i,1,k) - uc(i,1,k)*ud(i-1,1,k)*xloc(i-1 &
+ ,1,k) - ub(i,1,k)*ud_jm1(i,k)*xloc_jm1(i,k) - &
+ ua(i,1,k)*ud(i,1,k-1)*xloc(i,1,k-1)
+ END DO
+ END DO
+
+! [2D-K]
+ DO j = 2, j_e
+ DO i = 2, i_e
+ xloc(i,j,1) = bloc(i,j,1) - uc(i,j,1)*ud(i-1,j,1)*xloc(i-1 &
+ ,j,1) - ub(i,j,1)*ud(i,j-1,1)*xloc(i,j-1,1) - &
+ ua(i,j,1)*ud_km1(i,j)*xloc_km1(i,j)
+ END DO
+ END DO
+
+
+! [3D]
+ DO k = 2, k_e
+ DO j = 2, j_e
+ DO i = 2, i_e
+ xloc(i,j,k) = bloc(i,j,k) - uc(i,j,k)*ud(i-1,j,k)*xloc(i &
+ -1,j,k) - ub(i,j,k)*ud(i,j-1,k)*xloc(i,j-1,k) - &
+ ua(i,j,k)*ud(i,j,k-1)*xloc(i,j,k-1)
+ END DO
+ END DO
+ END DO
+
+
+! boundary exchange
+! [2D-I]
+ IF (ci==0) THEN
+ DO k = 1, k_e
+ DO j = 1, j_e
+ xloc_ip1(j,k) = xloc(i_e,j,k)
+ END DO
+ END DO
+ END IF
+
+! [2D-J]
+ IF (cj==0) THEN
+ DO k = 1, k_e
+ DO i = 1, i_e
+ xloc_jp1(i,k) = xloc(i,j_e,k)
+ END DO
+ END DO
+ END IF
+
+! [2D-K]
+ IF (ck==0) THEN
+ DO j = 1, j_e
+ DO i = 1, i_e
+ xloc_kp1(i,j) = xloc(i,j,k_e)
+ END DO
+ END DO
+ END IF
+
+!$OMP flush(xloc_ip1, xloc_jp1, xloc_kp1)
+
+ RETURN
+ END
+
+!> @brief compute [U]-part by solving [U] x [x] = [t]
+!> @param[in] ldI leading dimensions in I direction
+!> @param[in] ldJ leading dimensions in J direction
+!> @param[in] ldK leading dimensions in K direction
+!> @param[in] i_e block size in I direction
+!> @param[in] j_e block size in J direction
+!> @param[in] k_e block size in K direction
+!> @param[in,out] xloc result vector [x], [t] as input
+!> @param[in] UD thread local blocks of the helper diagonal [UD] of [U]
+!> @param[in] UE thread local blocks of the 2. diagonal of [U]
+!> @param[in] UF thread local blocks of the 3. diagonal of [U]
+!> @param[in] UG thread local blocks of the 4. diagonal of [U]
+!> @param[out] xloc_im1 global boundary buffer to the -1 neighbour in I direction
+!> @param[out] xloc_jm1 global boundary buffer to the -1 neighbour in J direction
+!> @param[out] xloc_km1 global boundary buffer to the -1 neighbour in K direction
+!> @param[in] xloc_ip1 global boundary buffer from the +1 neighbour in I direction
+!> @param[in] xloc_jp1 global boundary buffer from the +1 neighbour in J direction
+!> @param[in] xloc_kp1 global boundary buffer from the +1 neighbour in K direction
+!> @param[in] ci 0: copy boundary values in [xloc_im1], <>0: do nothing
+!> @param[in] cj 0: copy boundary values in [xloc_jm1], <>0: do nothing
+!> @param[in] ck 0: copy boundary values in [xloc_km1], <>0: do nothing
+ SUBROUTINE flu_right2(ldi,ldj,ldk,i_e,j_e,k_e,xloc,ud,ue,uf,ug, &
+ xloc_im1,xloc_jm1,xloc_km1,xloc_ip1,xloc_jp1,xloc_kp1,ci,cj, &
+ ck)
+ use mod_OMP_TOOLS
+ use mod_blocking_size
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+
+! N : length of all vectors r,z
+ INTEGER k_e, j_e, i_e, i, j, k, ldi, ldj, ldk, ci, cj, ck
+
+! vectors [z]
+ DOUBLE PRECISION xloc(ldi,ldj,ldk)
+ DOUBLE PRECISION ud(ldi,ldj,ldk), ue(ldi,ldj,ldk)
+ DOUBLE PRECISION uf(ldi,ldj,ldk), ug(ldi,ldj,ldk)
+
+! use mod_blocking_size
+! global boundary buffer
+ DOUBLE PRECISION xloc_im1(block_j,block_k)
+ DOUBLE PRECISION xloc_jm1(block_i,block_k)
+ DOUBLE PRECISION xloc_km1(block_i,block_j)
+ DOUBLE PRECISION xloc_ip1(block_j,block_k)
+ DOUBLE PRECISION xloc_jp1(block_i,block_k)
+ DOUBLE PRECISION xloc_kp1(block_i,block_j)
+
+!$OMP flush(xloc_ip1, xloc_jp1, xloc_kp1)
+
+! solve [U]x[x]=[t]
+! [0D]
+ xloc(i_e,j_e,k_e) = (xloc(i_e,j_e,k_e)-ue(i_e,j_e,k_e)* &
+ xloc_ip1(j_e,k_e)-uf(i_e,j_e,k_e)*xloc_jp1(i_e,k_e)- &
+ ug(i_e,j_e,k_e)*xloc_kp1(i_e,j_e))*ud(i_e,j_e,k_e)
+
+
+! [1D-I]
+ DO i = i_e - 1, 1, -1
+ xloc(i,j_e,k_e) = (xloc(i,j_e,k_e)-ue(i,j_e,k_e)*xloc(i+1, &
+ j_e,k_e)-uf(i,j_e,k_e)*xloc_jp1(i,k_e)- &
+ ug(i,j_e,k_e)*xloc_kp1(i,j_e))*ud(i,j_e,k_e)
+ END DO
+
+! [1D-J]
+ DO j = j_e - 1, 1, -1
+ xloc(i_e,j,k_e) = (xloc(i_e,j,k_e)-ue(i_e,j,k_e)*xloc_ip1(j, &
+ k_e)-uf(i_e,j,k_e)*xloc(i_e,j+1,k_e)- &
+ ug(i_e,j,k_e)*xloc_kp1(i_e,j))*ud(i_e,j,k_e)
+ END DO
+
+! [1D-K]
+ DO k = k_e - 1, 1, -1
+ xloc(i_e,j_e,k) = (xloc(i_e,j_e,k)-ue(i_e,j_e,k)*xloc_ip1( &
+ j_e,k)-uf(i_e,j_e,k)*xloc_jp1(i_e,k)- &
+ ug(i_e,j_e,k)*xloc(i_e,j_e,k+1))*ud(i_e,j_e,k)
+ END DO
+
+
+! [2D-I]
+ DO k = k_e - 1, 1, -1
+ DO j = j_e - 1, 1, -1
+ xloc(i_e,j,k) = (xloc(i_e,j,k)-ue(i_e,j,k)*xloc_ip1(j,k)- &
+ uf(i_e,j,k)*xloc(i_e,j+1,k)-ug(i_e,j,k)*xloc(i_e,j,k+1)) &
+ *ud(i_e,j,k)
+ END DO
+ END DO
+
+! [2D-J]
+ DO k = k_e - 1, 1, -1
+ DO i = i_e - 1, 1, -1
+ xloc(i,j_e,k) = (xloc(i,j_e,k)-ue(i,j_e,k)*xloc(i+1,j_e,k) &
+ -uf(i,j_e,k)*xloc_jp1(i,k)-ug(i,j_e,k)*xloc(i,j_e,k+1))* &
+ ud(i,j_e,k)
+ END DO
+ END DO
+
+! [2D-K]
+ DO j = j_e - 1, 1, -1
+ DO i = i_e - 1, 1, -1
+ xloc(i,j,k_e) = (xloc(i,j,k_e)-ue(i,j,k_e)*xloc(i+1,j,k_e) &
+ -uf(i,j,k_e)*xloc(i,j+1,k_e)-ug(i,j,k_e)*xloc_kp1(i,j))* &
+ ud(i,j,k_e)
+ END DO
+ END DO
+
+
+! [3D]
+ DO k = k_e - 1, 1, -1
+ DO j = j_e - 1, 1, -1
+ DO i = i_e - 1, 1, -1
+ xloc(i,j,k) = (xloc(i,j,k)-ue(i,j,k)*xloc(i+1,j,k)-uf(i, &
+ j,k)*xloc(i,j+1,k)-ug(i,j,k)*xloc(i,j,k+1))*ud(i,j,k)
+ END DO
+ END DO
+ END DO
+
+
+! boundary exchange
+! [2D-I]
+ IF (ci==0) THEN
+ DO k = 1, k_e
+ DO j = 1, j_e
+ xloc_im1(j,k) = xloc(1,j,k)
+ END DO
+ END DO
+ END IF
+
+! [2D-J]
+ IF (cj==0) THEN
+ DO k = 1, k_e
+ DO i = 1, i_e
+ xloc_jm1(i,k) = xloc(i,1,k)
+ END DO
+ END DO
+ END IF
+
+! [2D-K]
+ IF (ck==0) THEN
+ DO j = 1, j_e
+ DO i = 1, i_e
+ xloc_km1(i,j) = xloc(i,j,1)
+ END DO
+ END DO
+ END IF
+
+!$OMP flush(xloc_im1, xloc_jm1, xloc_km1)
+
+ RETURN
+ END
+
+!> @brief compute a processor grid distribution
+!> @param[in] lbl_size cache (block) size
+!> @param[in] P number of threads
+!> @param[out] bi block size in each dimension
+!> @param[out] bj block size in each dimension
+!> @param[out] bk block size in each dimension
+!> @param[in] ni grid dimension in I0 direction
+!> @param[in] nj grid dimension in I0 direction
+!> @param[in] nk grid dimension in I0 direction
+ SUBROUTINE proz_grid(lbl_size,p,bi,bj,bk,ni,nj,nk)
+ use mod_genrl
+ use mod_linfos
+ use mod_blocking_size
+ IMPLICIT NONE
+ integer :: i, j, k, l, m
+ INTEGER bi, bj, bk, p, ii, jj, kk,ni,nj,nk
+ INTEGER qwurz, lbl_size
+ INTRINSIC sqrt, max, dble, int
+ INTEGER vec_anz, ct_cm
+! vec_anz : [A B C + D + W + X] =#6
+ PARAMETER (vec_anz=6)
+ PARAMETER (ct_cm=55)
+ INTEGER cache2d_size
+! 8192 Double-Precisions (64KByte)
+ PARAMETER (cache2d_size = 8192)
+ DOUBLE PRECISION dii, djj, dkk, dti, dtj, dtk
+! ! manuell block size for benchmarking !
+ IF (linfos(4)==-1000) THEN
+ bi = block_i
+ bj = block_j
+ bk = block_k
+ RETURN
+ END IF
+! --------- NEW METHOD
+! compute block size for big models
+ IF (ni*nj*nk>=4*cache2d_size) THEN
+! - preset: I0 dimension
+ dii = -1.0d0
+ bi = -1
+ DO ii = min(ni,20), min(ni,70)
+ i = (ni-1) /ii
+ i = ni -i*ii
+ dti = dble(i)/dble(ii)
+ IF (dti>=dii) THEN
+ dii = dti -1.0D-10
+ bi = ii
+ END IF
+ END DO
+! - preset: J0 dimension
+ djj = -1.0d0
+ bj = -1
+ DO jj = min(nj,20), min(nj,40)
+ j = (nj-1) /jj
+ j = nj -j*jj
+ dtj = dble(j)/dble(jj)
+ IF (dtj>=djj) THEN
+ djj = dtj -1.0D-10
+ bj = jj
+ END IF
+ END DO
+! - preset: K0 dimension
+ dkk = -1.0d0
+ bk = -1
+ DO kk = nk, min(nk,4), -1
+ k = (nk-1) /kk
+ k = nk -k*kk
+ dtk = dble(k)/dble(kk)
+ IF (dtk>=dkk) THEN
+ dkk = dtk -1.0D-10
+ bk = kk
+ END IF
+ END DO
+! search in the I0,J0,K0 combination for a 64K-cache-fit
+ l = ni*nj*nk
+ DO kk = nk, min(nk,4), -1
+ k = (nk-1) /kk
+ k = nk -k*kk
+ dtk = dble(k)/dble(kk)
+ IF (dtk>=dkk) THEN
+ DO jj = min(nj,20), min(nj,40)
+ j = (nj-1) /jj
+ j = nj -j*jj
+ dtj = dble(j)/dble(jj)
+ IF (dtj>=djj) THEN
+ DO ii = min(ni,20), min(ni,70)
+ i = (ni-1) /ii
+ i = ni -i*ii
+ dti = dble(i)/dble(ii)
+ IF (dti>=dii) THEN
+! proof block size [m] close to cache block size [cache2d_size]
+ m = abs(ii*jj*kk -cache2d_size)
+ IF (m<=l) THEN
+ dii = dti -1.0D-10
+ bi = ii
+ djj = dtj -1.0D-10
+ bj = jj
+ dkk = dtk -1.0D-10
+ bk = kk
+ l = m
+ END IF
+ END IF
+ END DO
+ END IF
+ END DO
+ END IF
+ END DO
+ ELSE
+! --------- OLD METHOD
+! ! automatic block size computation !
+! minimal block length in I0 direction
+ IF (ni>ct_cm) THEN
+! 2D or 3D partitioning
+! a little bit more is better
+! 0.0-1.99: 1; 2.0-2.99: 2; ...
+ bi = max(ni/ct_cm,1)
+ bi = (ni-1)/bi + 1
+! number of blocks in J0*K0
+! ik_bl = bi*J0*K0*veC_anz/lbl_size
+! size of J0*K0 blocks matching the cache size
+! J0*K0/ik_bl
+! ideal size for J0 and K0
+! qwurz = int(sqrt(dble(J0*K0/ik_bl)))
+ qwurz = max(int(sqrt(dble(lbl_size/(bi*vec_anz)))),1)
+! J0 dimension
+! a little bit more is better
+! 0.0-1.99: 1; 2.0-2.99: 2; ...
+ bj = (nj-1)/qwurz + 1
+ bj = (nj-1)/bj + 1
+! rest for K0 dimension
+! a little bit more is better
+! 0.0-1.99: 1; 2.0-2.99: 2; ...
+ bk = vec_anz*(nk-1)*bj*bi/lbl_size + 1
+ bk = (nk-1)/bk + 1
+ ELSE IF (ni*nj>ct_cm) THEN
+! simple 2D partitioning, when enough elements
+! I0 dimension
+ bi = ni
+! number of cache blocks in J0*K0
+! (J0 *K0 *vec_anz *bi) /lbl_size
+! ideal size for J0 and K0
+ qwurz = max(int(sqrt(dble((nj*nk*vec_anz*bi)/lbl_size))),1)
+! J0 dimension
+! a little bit more is better
+! 0.0-1.99: 1; 2.0-2.99: 2; ...
+ bj = max(ni*nj/ct_cm,1)
+ bj = (nj-1)/bj + 1
+ bj = max(bj,(nj-1)/qwurz+1)
+! rest for K0 dimension
+! a little bit more is better
+! 0.0-1.99: 1; 2.0-2.99: 2; ...
+ bk = vec_anz*(nk-1)*bj*bi/lbl_size + 1
+ bk = (nk-1)/bk + 1
+ ELSE
+! ! in case of a 2D model and a too small I0, no parallelization !
+ bi = ni
+ bj = nj
+ bk = nk
+ END IF
+ END IF
+! ---------
+ RETURN
+ END
+
+!> @param[in] ni grid dimension in I0 direction
+!> @param[in] nj grid dimension in J0 direction
+!> @param[in] nk grid dimension in K0 direction
+!> @brief initialise [proza]-thread association for parallel computation
+ SUBROUTINE par_init2(ni,nj,nk)
+ use arrays
+ use mod_genrl
+ use mod_linfos
+ use mod_OMP_TOOLS
+ use mod_blocking_size
+ IMPLICIT NONE
+ integer :: i, j, k
+ INCLUDE 'OMP_TOOLS.inc'
+ INTEGER bi, bj, bk, p, pa, ni,nj,nk
+ INTEGER li, lj, lk, maxlevel
+ INTEGER, ALLOCATABLE :: speed(:)
+ INTEGER, ALLOCATABLE :: nbl_proz(:), sbl_proz(:), lev_idx(:,:)
+ INTEGER ilev_b, ilev_e, pro_b, pro_e, t_max
+ INTEGER subbl, parmax, parlen
+ PARAMETER (subbl=16)
+ DOUBLE PRECISION speedup, speedup_vec
+! use mod_blocking_size
+ INTRINSIC max, min, log10, dble, int
+#ifdef BENCH
+ character (len=40) :: bench_format
+#endif
+
+! number of processors
+ p = tlevel_1
+
+! minimal block length for each dimension
+ i = subbl + 1
+123 i = i - 1
+ CALL proz_grid(i*bl_size/subbl,p,bi,bj,bk,ni,nj,nk)
+ li = (ni-1)/bi + 1
+ lj = (nj-1)/bj + 1
+ lk = (nk-1)/bk + 1
+! max. useable threads
+ parmax = max(max(min(li,lj),min(li,lk)),min(lj,lk))
+! # of max. thread runs
+ parlen = max(max(li,lj),lk) - min(parmax,p)
+!debug write(*,*) '[parmax,parlen,i]:',parmax,parlen,i
+ IF ((parmax<p .OR. parlen<p) .AND. i>1) GO TO 123
+
+ block_i = bi
+ block_j = bj
+ block_k = bk
+ bdim_i = li
+ bdim_j = lj
+ bdim_k = lk
+
+ ALLOCATE(proza(li,lj,lk))
+
+! compute levels, all blocks for the same level are independent
+ maxlevel = 0
+ DO k = 1, lk
+ DO j = 1, lj
+ DO i = 1, li
+ proza(i,j,k) = 0
+! set to maximum of all previous neighboars
+ IF (i>1) proza(i,j,k) = max(proza(i,j,k),proza(i-1,j,k))
+ IF (j>1) proza(i,j,k) = max(proza(i,j,k),proza(i,j-1,k))
+ IF (k>1) proza(i,j,k) = max(proza(i,j,k),proza(i,j,k-1))
+! increase level
+ proza(i,j,k) = proza(i,j,k) + 1
+ maxlevel = max(maxlevel,proza(i,j,k))
+ END DO
+ END DO
+ END DO
+
+ ALLOCATE(speed(maxlevel))
+ DO i = 1, maxlevel
+ speed(i) = 0
+ END DO
+! estimate max number of threads per level
+ DO k = 1, lk
+ DO j = 1, lj
+ DO i = 1, li
+! ProzA from 1..(P)
+ speed(proza(i,j,k)) = speed(proza(i,j,k)) + 1
+ END DO
+ END DO
+ END DO
+! PA: maximum number of independent threads over all levels
+! speedup : approx. speedup
+ pa = 0
+ speedup = 0.0D0
+ DO i = 1, maxlevel
+ pa = max(speed(i),pa)
+ speedup = speedup + dble(speed(i))/dble(min(speed(i),p))
+ END DO
+ speedup = dble(li*lj*lk)/speedup
+
+
+! max number of blocks for each thread
+ ALLOCATE(nbl_proz(p))
+! used (setup) number of blocks for each thread during each level
+ ALLOCATE(sbl_proz(p))
+! index of blocks for this level
+ ALLOCATE(lev_idx(3,pa))
+
+! number of blocks equal for each thread
+ i = (li*lj*lk)/p
+ DO j = 1, p
+ nbl_proz(j) = i
+ END DO
+! overhead of blocks distributed over all threads
+ i = li*lj*lk - i*p
+ DO j = 1, i
+ nbl_proz(j) = nbl_proz(j) + 1
+ END DO
+ speedup_vec = dble(li*lj*lk)/dble(nbl_proz(1))
+! max number of blocks (the first thread has the highest number)
+ max_blocks = nbl_proz(1)
+
+! for each level distribute the blocks of each thread (bi-directional)
+ ilev_b = 1
+ ilev_e = maxlevel
+1000 CONTINUE
+! first: forward direction
+! init
+ pro_b = 0
+ t_max = 0
+ DO i = 1, p
+ sbl_proz(i) = 0
+ END DO
+! search for the 'ilev_b' level
+ DO k = 1, lk
+ DO j = 1, lj
+ DO i = 1, li
+! right [i,j,k]-index for this level
+ IF (proza(i,j,k)==ilev_b) THEN
+ t_max = t_max + 1
+! next thread with free blocks
+1001 pro_b = mod(pro_b,p) + 1
+! skip this thread:
+! 1. no blocks
+! 2. already one block
+! and not enough for later levels
+ IF (nbl_proz(pro_b)<=0 .OR. (sbl_proz(pro_b)>0 .AND. ( &
+ maxlevel-2*ilev_b+1)>=nbl_proz(pro_b))) GO TO 1001
+! mark the block for this level
+ nbl_proz(pro_b) = nbl_proz(pro_b) - 1
+ sbl_proz(pro_b) = sbl_proz(pro_b) + 1
+ lev_idx(1,t_max) = i
+ lev_idx(2,t_max) = j
+ lev_idx(3,t_max) = k
+ END IF
+ END DO
+ END DO
+ END DO
+! distribute the blocks
+ pro_b = 1
+ CALL distribute_bl(t_max,p,pro_b,sbl_proz,lev_idx)
+! second: backward direction
+ IF (ilev_b==ilev_e) GO TO 1020
+! init
+ pro_e = 1
+ t_max = 0
+ DO i = 1, p
+ sbl_proz(i) = 0
+ END DO
+! search for the 'ilev_e' level
+ DO k = lk, 1, -1
+ DO j = lj, 1, -1
+ DO i = li, 1, -1
+! right [i,j,k]-index for this level
+ IF (proza(i,j,k)==ilev_e) THEN
+ t_max = t_max + 1
+! next thread with free blocks
+1011 pro_e = mod(pro_e+p-2,p) + 1
+! skip this thread:
+! 1. no blocks
+! 2. already one block
+! and not enough for later levels
+ IF (nbl_proz(pro_e)<=0 .OR. (sbl_proz(pro_e)>0 .AND. ( &
+ maxlevel-2*ilev_b)>=nbl_proz(pro_e))) GO TO 1011
+! mark the block for this level
+ nbl_proz(pro_e) = nbl_proz(pro_e) - 1
+ sbl_proz(pro_e) = sbl_proz(pro_e) + 1
+ lev_idx(1,t_max) = i
+ lev_idx(2,t_max) = j
+ lev_idx(3,t_max) = k
+ END IF
+ END DO
+ END DO
+ END DO
+! distribute the blocks
+ pro_e = p
+ CALL distribute_bl(t_max,p,pro_e,sbl_proz,lev_idx)
+
+! next levels
+1020 CONTINUE
+ ilev_b = ilev_b + 1
+ ilev_e = ilev_e - 1
+ IF (ilev_b<=ilev_e) GO TO 1000
+
+
+ DEALLOCATE(lev_idx)
+ DEALLOCATE(sbl_proz)
+ DEALLOCATE(nbl_proz)
+ DEALLOCATE(speed)
+
+! setup return values
+ DO k = 1, lk
+ DO j = 1, lj
+ DO i = 1, li
+! ProzA : [0..(PA-1)]
+ proza(i,j,k) = -proza(i,j,k) - 1
+ END DO
+ END DO
+ END DO
+
+#ifdef BENCH
+ IF (p>1) THEN
+ WRITE(*,'(A)') ' [I] : ILU block - thread assignment:'
+ WRITE(bench_format,'(A,I2,A,I2,A,I2,A)') '(7X,', lk, '(', &
+ li, 'I', int(log10(dble(pa))) + 2, ',2X))'
+ DO j = 1, lj
+ WRITE(*,bench_format) ((proza(i,j,k),i=1,li),k=1,lk)
+ END DO
+ END IF
+! 'speed' should now be the number of blocks for each thread
+!aw write(*,'(A)') ' [I] : Number of bloCks for eaCh thread:'
+!aw write (benCh_format,'(A,I2,A,I2,A)') '(A,',P,'I',
+!aw & int(log10(dble(speed(1))))+2,',A)'
+!aw write(*,benCh_format) ' [',(i-1,i=1,P),'] thread'
+!aw write(*,benCh_format) ' [',(speed(i),i=1,P),'] bloCks'
+ WRITE(*,'(A,3(I5,A),3(I3,A))') ' [I] : ILU: block size =[', &
+ bi, ',', bj, ',', bk, '], dim=[', li, ',', lj, ',', lk, ']'
+ WRITE(*,'(A,F7.2)') &
+ ' theoretical speedup for solver only :', speedup_vec
+ WRITE(*,'(A,F7.2)') &
+ ' theoretical speedup for ILU only :', speedup
+ CALL write_grid()
+#endif
+ IF (linfos(4)>=1) THEN
+ WRITE(*,'(A,F7.2)') &
+ ' [I] : approx. speedup for the full solver :', &
+ (2.0D0*speedup+1.0D0*speedup_vec)/3.0D0
+ END IF
+
+ RETURN
+ END
+
+!> @brief search for nearest neighbours and distributes the blocks, writes output in [proza]
+!> @param[in] t_max number of blocks
+!> @param[in] P number of threads (processor cores)
+!> @param[in] pro_be initial thread index, switch with 1: forward counting, [P]: backward counting
+!> @param[in,out] sbl_proz blocks per thread counter
+!> @param[in] lev_idx i,j,k index for each block
+ SUBROUTINE distribute_bl(t_max,p,pro_be,sbl_proz,lev_idx)
+ use arrays
+ use mod_OMP_TOOLS
+ use mod_genrl
+ use mod_linfos
+ use mod_blocking_size
+ IMPLICIT NONE
+ integer :: i, j, k
+ INCLUDE 'OMP_TOOLS.inc'
+ INTEGER p, t_max, pro_be
+ INTEGER sbl_proz(p), lev_idx(3,t_max)
+ INTEGER tidx, ii, jj, kk, ll, mm
+
+ tidx = pro_be
+ DO ii = 1, t_max
+! thread for the next block
+2001 IF (sbl_proz(tidx)<=0) THEN
+ IF (pro_be==p) THEN
+! backward
+ tidx = mod(tidx+p-2,p) + 1
+ ELSE
+! forward
+ tidx = mod(tidx,p) + 1
+ END IF
+ GO TO 2001
+ END IF
+ sbl_proz(tidx) = sbl_proz(tidx) - 1
+! search the best fit (kk: most neighboars)
+ ll = -1
+ mm = 1
+ DO jj = 1, t_max
+ i = lev_idx(1,jj)
+ j = lev_idx(2,jj)
+ k = lev_idx(3,jj)
+ kk = 0
+ IF (i>1) THEN
+ IF (proza(i-1,j,k)==-tidx) kk = kk + 1
+ END IF
+ IF (j>1) THEN
+ IF (proza(i,j-1,k)==-tidx) kk = kk + 1
+ END IF
+ IF (k>1) THEN
+ IF (proza(i,j,k-1)==-tidx) kk = kk + 1
+ END IF
+ IF (i<bdim_i) THEN
+ IF (proza(i+1,j,k)==-tidx) kk = kk + 1
+ END IF
+ IF (j<bdim_j) THEN
+ IF (proza(i,j+1,k)==-tidx) kk = kk + 1
+ END IF
+ IF (k<bdim_k) THEN
+ IF (proza(i,j,k+1)==-tidx) kk = kk + 1
+ END IF
+ IF (kk>ll .AND. proza(i,j,k)>=0) THEN
+! better fit
+ ll = kk
+ mm = jj
+ END IF
+ END DO
+ proza(lev_idx(1,mm),lev_idx(2,mm),lev_idx(3,mm)) = -tidx
+! old strait-forward distribution
+!aw ProzA(lev_idx(1,i),lev_idx(2,i),lev_idx(3,i)) = -tidx
+ END DO
+ RETURN
+ END
+
+!> @brief function wrapper for array [proza]
+!> @param[in] i cell index, direction I0
+!> @param[in] j cell index, direction J0
+!> @param[in] k cell index, direction K0
+!> @return value of [proza(i,j,k)]
+ INTEGER FUNCTION fkt_proza(i,j,k)
+ use arrays
+ IMPLICIT NONE
+ INTEGER i, j, k
+
+ fkt_proza = proza(i,j,k)
+
+ RETURN
+ END
+
+!> @brief writes ILU thread grid in tecplot-format
+!> @details
+!> writes ILU thread grid in tecplot-format\n
+!> for each block an eight-node cube is created\n
+ SUBROUTINE write_grid()
+ use arrays
+ use mod_blocking_size
+ IMPLICIT NONE
+! use mod_blocking_size
+ INTEGER i, j, k
+
+
+ OPEN(76,file='thread_grid.plt',status='unknown',blank='null')
+
+ WRITE(76,'(1A)') 'variables = "i", "j", "k", "thread"'
+ WRITE(76,'(3(1A,I5),1A)') 'zone i=', bdim_i*2, ', j=', &
+ bdim_j*2, ', k=', bdim_k*2, ', f=point'
+
+ DO k = 1, bdim_k
+ DO j = 1, bdim_j
+ DO i = 1, bdim_i
+ WRITE(76,'(3F6.2,1I6)') dble(i) - 0.99D0, &
+ dble(j) - 0.99D0, dble(k) - 0.99D0, proza(i,j,k)
+ WRITE(76,'(3F6.2,1I6)') dble(i), dble(j) - 0.99D0, &
+ dble(k) - 0.99D0, proza(i,j,k)
+ END DO
+ DO i = 1, bdim_i
+ WRITE(76,'(3F6.2,1I6)') dble(i) - 0.99D0, dble(j), &
+ dble(k) - 0.99D0, proza(i,j,k)
+ WRITE(76,'(3F6.2,1I6)') dble(i), dble(j), &
+ dble(k) - 0.99D0, proza(i,j,k)
+ END DO
+ END DO
+ DO j = 1, bdim_j
+ DO i = 1, bdim_i
+ WRITE(76,'(3F6.2,1I6)') dble(i) - 0.99D0, &
+ dble(j) - 0.99D0, dble(k), proza(i,j,k)
+ WRITE(76,'(3F6.2,1I6)') dble(i), dble(j) - 0.99D0, &
+ dble(k), proza(i,j,k)
+ END DO
+ DO i = 1, bdim_i
+ WRITE(76,'(3F6.2,1I6)') dble(i) - 0.99D0, dble(j), &
+ dble(k), proza(i,j,k)
+ WRITE(76,'(3F6.2,1I6)') dble(i), dble(j), dble(k), &
+ proza(i,j,k)
+ END DO
+ END DO
+ END DO
+
+ CLOSE(76)
+ RETURN
+ END
diff --git a/solve/omp_sym_solve.f90 b/solve/omp_sym_solve.f90
new file mode 100644
index 0000000..2c3286a
--- /dev/null
+++ b/solve/omp_sym_solve.f90
@@ -0,0 +1,180 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief solve of : [M] x [x] = [b], CG algorithm based
+!> @param[in] N_I lengths of I dimension of local matrix [M]
+!> @param[in] N_J lengths of J dimension of local matrix [M]
+!> @param[in] N_K lengths of K dimension of local matrix [M]
+!> @param[in,out] x solution vector [x], on start = start vector
+!> @param[in] b right side, vector [b]
+!> @param[in] depsilon precision criteria to break iterations
+!> @param[in] max_It max iteration number
+!> @param[in] criteria precision criteria mode to break iterations\n
+!> - 0 : relative stopping crit.: ||[res]|| < depsilon*||[res0]||\n
+!> - 1 : absolute stopping crit.: ||[res]|| < depsilon\n
+!> - 2 : maximum stopping crit.: max(abs([res])) < depsilon\n
+!> first [res]^=[r], later (if precise enough): [res]^=([M]x[x]-[b])
+!> @param[in] mbc_mask boundary condition pattern (mask)
+!> @param[in] MA 1. diagonal of the system matrix [M]
+!> @param[in] MB 2. diagonal of the system matrix [M]
+!> @param[in] MC 3. diagonal of the system matrix [M]
+!> @param[in] MD 4. diagonal of the system matrix [M]
+!> @param[in] ME 5. diagonal of the system matrix [M]
+!> @param[in] MF 6. diagonal of the system matrix [M]
+!> @param[in] MG 7. diagonal of the system matrix [M]
+!> @param[out] locTMP local temporary vectors
+!> @param[out] dnrm normalisation vector, temporary use
+!> @param[in] ismpl local sample index
+!> @details
+!> solve of : [M] x [x] = [b]\n
+!> [M] is s.p.d. Matrix, only used in 'omp_MVP'\n
+!> Technics :\n
+!> - use reverse communication technics.\n
+!> each vector should be dense full without any hole,\n
+!> ( you can copy your elements from your structure to a \n
+!> temporary dense full vector, befor you use this algorithm \n
+!> and give the correct number of elements in 'N' ).\n
+!> if you have setup all vectors by a specific composition,\n
+!> each vector (x,b,r,...) on the same thread should use\n
+!> the same composition (same structure for all vectors on\n
+!> one thread).\n
+ SUBROUTINE omp_sym_solve(n_i,n_j,n_k,x,b,depsilon,mbc_mask, &
+ max_it,criteria,ma,mb,mc,md,me,mf,mg,loctmp,dnrm,ismpl)
+ use mod_OMP_TOOLS
+ use mod_blocking_size
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+
+! N : length of all vector x, r, z, s, b, p, q
+! ld_N : leading dimension of [locTMP]
+ INTEGER n, n_i, n_j, n_k, max_it, ismpl
+
+! thread stuff
+ INTEGER tanz, tpos
+
+! vector x and b for [M]x[x]=[b]
+! res0 ^= ||res0||, start residuel, given for 'criteria=0'
+ DOUBLE PRECISION x(n_i*n_j*n_k), b(n_i*n_j*n_k)
+ DOUBLE PRECISION res0
+ CHARACTER mbc_mask(n_i*n_j*n_k)
+ DOUBLE PRECISION ma(n_i*n_j*n_k), mb(n_i*n_j*n_k), &
+ mc(n_i*n_j*n_k)
+ DOUBLE PRECISION md(n_i*n_j*n_k), me(n_i*n_j*n_k), &
+ mf(n_i*n_j*n_k)
+ DOUBLE PRECISION mg(n_i*n_j*n_k)
+
+! definitions of 'work' and 'locTMP'
+ INCLUDE 'pre_cg.inc'
+! locTMP : space for local vectors, using to exchange data with
+! 'matrix-vector-product'(MVP) and 'pre-conditioners'(L/R),
+! for definitions see more in 'pre_bicgstab.inc'
+ DOUBLE PRECISION loctmp(n_i*n_j*n_k,max_loctmp)
+ DOUBLE PRECISION dnrm(n_i*n_j*n_k)
+
+! Pre_CG stuff
+! work : control variable : what is to do out of this subroutine,
+! see more discription in 'pre_cg.inc',
+! on startup should set to 'work=START'
+ INTEGER work
+
+! break with enough precision
+ DOUBLE PRECISION depsilon
+
+ INTEGER criteria
+! openmp-shared variables
+ INTEGER ipar(5), iii
+ DOUBLE PRECISION, ALLOCATABLE :: rpar(:)
+ LOGICAL lpar(1)
+
+
+! full number of elements
+ n = n_i*n_j*n_k
+ res0 = 1.D+99
+
+
+!**************************************************************
+
+! start values
+ work = start
+
+!$OMP parallel &
+!$OMP num_threads(Tlevel_1) &
+!$OMP default(shared) &
+!$OMP private(tanz,tpos,iii)
+!$ call omp_binding(ismpl)
+
+ CALL omp_part(n,tpos,tanz)
+
+!$OMP master
+ iii = 6 + 4*omp_get_num_of_threads()
+ ALLOCATE(rpar(iii))
+ CALL set_dval(iii,0.D0,rpar)
+!$OMP end master
+! normalise the linear system, use [dnrm] to normalise the system
+ CALL norm_linsys(tanz,mbc_mask(tpos),b(tpos),x(tpos),ma(tpos), &
+ mb(tpos),mc(tpos),md(tpos),me(tpos),mf(tpos),mg(tpos), &
+ dnrm(tpos))
+!$OMP barrier
+
+! preload ([M]x[x]) in [s]
+ CALL omp_mvp(n_i,n_j,n_k,x,loctmp(1,s),ma,mb,mc,md,me,mf,mg)
+! implicit barrier here
+
+10 CONTINUE
+
+
+! cg-routines without Pre-Cond.
+! step : is the return-lable for pre_cg()
+ CALL pre_cg(tanz,x(tpos),b(tpos),n,loctmp(tpos,1),depsilon, &
+ dnrm(tpos),max_it,criteria,res0,work,ipar,rpar,lpar)
+! implicit barrier here
+
+ IF ((work==mvp) .OR. (work==mvpx)) THEN
+! solve: [M]x[z]=[r] -> [z]:=[A^-1]x[r]
+! here [M] can be a substituted Matrix [T] -> solve: [T]x[z]=[r]
+ CALL myprco(n,loctmp(1,r),loctmp(1,z))
+!$OMP barrier
+
+! [s]:=[M]x[z]
+ CALL omp_mvp(n_i,n_j,n_k,loctmp(1,z),loctmp(1,s),ma,mb,mc, &
+ md,me,mf,mg)
+! implicit barrier here
+ END IF
+
+! [v]:=[M]x[x], for advanced precision
+ IF (work==mvpx) CALL omp_mvp(n_i,n_j,n_k,x,loctmp(1,v),ma,mb, &
+ mc,md,me,mf,mg)
+! implicit barrier here
+
+
+! precision not enough ?
+ IF ((work/=fine) .AND. (work/=abort)) GO TO 10
+
+!$OMP end parallel
+
+ DEALLOCATE(rpar)
+
+!**************************************************************
+
+
+ RETURN
+ END
diff --git a/solve/omp_sym_solve_diag.f90 b/solve/omp_sym_solve_diag.f90
new file mode 100644
index 0000000..7d3992c
--- /dev/null
+++ b/solve/omp_sym_solve_diag.f90
@@ -0,0 +1,181 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief solve of : [M] x [x] = [b], CG algorithm based with Diagonal preconditioning
+!> @param[in] N_I lengths of I dimension of local matrix [M]
+!> @param[in] N_J lengths of J dimension of local matrix [M]
+!> @param[in] N_K lengths of K dimension of local matrix [M]
+!> @param[in,out] x solution vector [x], on start = start vector
+!> @param[in] b right side, vector [b]
+!> @param[in] depsilon precision criteria to break iterations
+!> @param[in] max_It max iteration number
+!> @param[in] criteria precision criteria mode to break iterations\n
+!> - 0 : relative stopping crit.: ||[res]|| < depsilon*||[res0]||\n
+!> - 1 : absolute stopping crit.: ||[res]|| < depsilon\n
+!> - 2 : maximum stopping crit.: max(abs([res])) < depsilon\n
+!> first [res]^=[r], later (if precise enough): [res]^=([M]x[x]-[b])
+!> @param[in] mbc_mask boundary condition pattern (mask)
+!> @param[in] MA 1. diagonal of the system matrix [M]
+!> @param[in] MB 2. diagonal of the system matrix [M]
+!> @param[in] MC 3. diagonal of the system matrix [M]
+!> @param[in] MD 4. diagonal of the system matrix [M]
+!> @param[in] ME 5. diagonal of the system matrix [M]
+!> @param[in] MF 6. diagonal of the system matrix [M]
+!> @param[in] MG 7. diagonal of the system matrix [M]
+!> @param[out] locTMP local temporary vectors
+!> @param[out] dnrm normalisation vector, temporary use
+!> @param[in] ismpl local sample index
+!> @details
+!> solve of : [M] x [x] = [b]\n
+!> [M] is s.p.d. Matrix, only used in 'omp_MVP'\n
+!> Technics :\n
+!> - use reverse communication technics.\n
+!> each vector should be dense full without any hole,\n
+!> ( you can copy your elements from your structure to a \n
+!> temporary dense full vector, befor you use this algorithm \n
+!> and give the correct number of elements in 'N' ).\n
+!> if you have setup all vectors by a specific composition,\n
+!> each vector (x,b,r,...) on the same thread should use\n
+!> the same composition (same structure for all vectors on\n
+!> one thread).\n
+ SUBROUTINE omp_sym_solve_diag(n_i,n_j,n_k,x,b,depsilon,mbc_mask, &
+ max_it,criteria,ma,mb,mc,md,me,mf,mg,loctmp,dnrm,ismpl)
+ use mod_OMP_TOOLS
+ use mod_blocking_size
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+
+! N : length of all vector x, r, z, s, b, p, q
+! ld_N : leading dimension of [locTMP]
+ INTEGER n, n_i, n_j, n_k, max_it, ismpl
+
+! thread stuff
+ INTEGER tanz, tpos
+
+! vector x and b for [M]x[x]=[b]
+! res0 ^= ||res0||, start residuel, given for 'criteria=0'
+ DOUBLE PRECISION x(n_i*n_j*n_k), b(n_i*n_j*n_k)
+ DOUBLE PRECISION res0
+ CHARACTER mbc_mask(n_i*n_j*n_k)
+ DOUBLE PRECISION ma(n_i*n_j*n_k), mb(n_i*n_j*n_k), &
+ mc(n_i*n_j*n_k)
+ DOUBLE PRECISION md(n_i*n_j*n_k), me(n_i*n_j*n_k), &
+ mf(n_i*n_j*n_k)
+ DOUBLE PRECISION mg(n_i*n_j*n_k)
+
+! definitions of 'work' and 'locTMP'
+ INCLUDE 'pre_cg.inc'
+! locTMP : space for local vectors, using to exchange data with
+! 'matrix-vector-product'(MVP) and 'pre-conditioners'(L/R),
+! for definitions see more in 'pre_bicgstab.inc'
+ DOUBLE PRECISION loctmp(n_i*n_j*n_k,max_loctmp)
+ DOUBLE PRECISION dnrm(n_i*n_j*n_k)
+
+! Pre_CG stuff
+! work : control variable : what is to do out of this subroutine,
+! see more discription in 'pre_cg.inc',
+! on startup should set to 'work=START'
+ INTEGER work
+
+! break with enough precision
+ DOUBLE PRECISION depsilon
+
+ INTEGER criteria
+! openmp-shared variables
+ INTEGER ipar(5), iii
+ DOUBLE PRECISION, ALLOCATABLE :: rpar(:)
+ LOGICAL lpar(1)
+
+
+! full number of elements
+ n = n_i*n_j*n_k
+ res0 = 1.D+99
+
+
+!**************************************************************
+
+! start values
+ work = start
+
+!$OMP parallel &
+!$OMP num_threads(Tlevel_1) &
+!$OMP default(shared) &
+!$OMP private(tanz,tpos,iii)
+!$ call omp_binding(ismpl)
+
+ CALL omp_part(n,tpos,tanz)
+
+!$OMP master
+ iii = 6 + 4*omp_get_num_of_threads()
+ ALLOCATE(rpar(iii))
+ CALL set_dval(iii,0.D0,rpar)
+! allocate(rpar(6 +4 *OMP_GET_NUM_of_THREADS()))
+!$OMP end master
+! normalise the linear system, use [dnrm] to normalise the system
+ CALL norm_linsys(tanz,mbc_mask(tpos),b(tpos),x(tpos),ma(tpos), &
+ mb(tpos),mc(tpos),md(tpos),me(tpos),mf(tpos),mg(tpos), &
+ dnrm(tpos))
+!$OMP barrier
+
+! preload ([M]x[x]) in [s]
+ CALL omp_mvp(n_i,n_j,n_k,x,loctmp(1,s),ma,mb,mc,md,me,mf,mg)
+! implicit barrier here
+
+10 CONTINUE
+
+
+! cg-routines without Pre-Cond.
+! step : is the return-lable for pre_cg()
+ CALL pre_cg(tanz,x(tpos),b(tpos),n,loctmp(tpos,1),depsilon, &
+ dnrm(tpos),max_it,criteria,res0,work,ipar,rpar,lpar)
+! implicit barrier here
+
+ IF ((work==mvp) .OR. (work==mvpx)) THEN
+! solve: [M]x[z]=[r] -> [z]:=[A^-1]x[r]
+! here [M] can be a substituted Matrix [T] -> solve: [T]x[z]=[r]
+ CALL diagprco(n,md,loctmp(1,r),loctmp(1,z))
+!$OMP barrier
+
+! [s]:=[M]x[z]
+ CALL omp_mvp(n_i,n_j,n_k,loctmp(1,z),loctmp(1,s),ma,mb,mc, &
+ md,me,mf,mg)
+! implicit barrier here
+ END IF
+
+! [v]:=[M]x[x], for advanced precision
+ IF (work==mvpx) CALL omp_mvp(n_i,n_j,n_k,x,loctmp(1,v),ma,mb, &
+ mc,md,me,mf,mg)
+! implicit barrier here
+
+
+! precision not enough ?
+ IF ((work/=fine) .AND. (work/=abort)) GO TO 10
+
+!$OMP end parallel
+
+ DEALLOCATE(rpar)
+
+!**************************************************************
+
+
+ RETURN
+ END
diff --git a/solve/omp_sym_solve_ilu.f90 b/solve/omp_sym_solve_ilu.f90
new file mode 100644
index 0000000..1ec96fa
--- /dev/null
+++ b/solve/omp_sym_solve_ilu.f90
@@ -0,0 +1,302 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief solve of : [M] x [x] = [b], CG algorithm based with ILU preconditioning
+!> @param[in] N_I lengths of I dimension of local matrix [M]
+!> @param[in] N_J lengths of J dimension of local matrix [M]
+!> @param[in] N_K lengths of K dimension of local matrix [M]
+!> @param[in,out] x solution vector [x], on start = start vector
+!> @param[in] b right side, vector [b]
+!> @param[in] depsilon precision criteria to break iterations
+!> @param[in] mbc_mask boundary condition pattern (mask)
+!> @param[in] max_It max iteration number
+!> @param[in] criteria precision criteria mode to break iterations\n
+!> - 0 : relative stopping crit.: ||[res]|| < depsilon*||[res0]||\n
+!> - 1 : absolute stopping crit.: ||[res]|| < depsilon\n
+!> - 2 : maximum stopping crit.: max(abs([res])) < depsilon\n
+!> first [res]^=[r], later (if precise enough): [res]^=([M]x[x]-[b])
+!> @param[in] MA 1. diagonal of the system matrix [M]
+!> @param[in] MB 2. diagonal of the system matrix [M]
+!> @param[in] MC 3. diagonal of the system matrix [M]
+!> @param[in] MD 4. diagonal of the system matrix [M]
+!> @param[in] ME 5. diagonal of the system matrix [M]
+!> @param[in] MF 6. diagonal of the system matrix [M]
+!> @param[in] MG 7. diagonal of the system matrix [M]
+!> @param[in] UD helper diagonal elements for preconditioning
+!> @param[out] bound_block boundary exchange buffer for each block, between the threads
+!> @param[out] dnrm normalisation vector, temporary use
+!> @param[out] lMA temporary thread local elements of the 1. diagonal of [M]
+!> @param[out] lMB temporary thread local elements of the 2. diagonal of [M]
+!> @param[out] lMC temporary thread local elements of the 3. diagonal of [M]
+!> @param[out] lMD temporary thread local elements of the 4. diagonal of [M]
+!> @param[out] lME temporary thread local elements of the 5. diagonal of [M]
+!> @param[out] lMF temporary thread local elements of the 6. diagonal of [M]
+!> @param[out] lMG temporary thread local elements of the 7. diagonal of [M]
+!> @param[out] lUD temporary thread local elements of the helper diagonal [UD]
+!> @param[out] lx temporary thread local elements of the solution vector [x]
+!> @param[out] lb temporary thread local elements of the right side [b]
+!> @param[out] ldnrm temporary thread local elements of the normalisation vector
+!> @param[out] llocTMP temporary thread local elements of the local temporary vectors
+!> @param[out] ud_block block buffer for helper diagonal [UD]
+!> @param[in] ismpl local sample index
+!> @details
+!> solve of : [M] x [x] = [b]\n
+!> [M] is s.p.d. Matrix, only used in 'omp_MVP'\n
+!> Technics :\n
+!> - use reverse communication technics.\n
+!> each vector should be dense full without any hole,\n
+!> ( you can copy your elements from your structure to a \n
+!> temporary dense full vector, befor you use this algorithm \n
+!> and give the correct number of elements in 'N' ).\n
+!> if you have setup all vectors by a specific composition,\n
+!> each vector (x,b,r,...) on the same thread should use\n
+!> the same composition (same structure for all vectors on\n
+!> one thread).\n
+ SUBROUTINE omp_sym_solve_ilu(n_i,n_j,n_k,x,b,depsilon,mbc_mask, &
+ max_it,criteria,ma,mb,mc,md,me,mf,mg,ud,bound_block,dnrm, &
+ lma,lmb,lmc,lmd,lme,lmf,lmg,lud,lx,lb,ldnrm,lloctmp, &
+ ud_block,ismpl)
+ use mod_OMP_TOOLS
+ use mod_blocking_size
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+
+! N_I*N_J*N_K : length of all vector r,z,s,t,v,p,y,t_pc,s_pc
+ INTEGER n_i, n_j, n_k, max_it, ismpl
+
+! vector x and b for [M]x[x]=[b]
+! res0 ^= ||res0||, start residuel, given for 'criteria=0'
+ DOUBLE PRECISION x(n_i*n_j*n_k), b(n_i*n_j*n_k)
+ DOUBLE PRECISION res0, ud(n_i*n_j*n_k)
+ DOUBLE PRECISION ma(n_i*n_j*n_k), mb(n_i*n_j*n_k)
+ DOUBLE PRECISION mc(n_i*n_j*n_k), md(n_i*n_j*n_k)
+ DOUBLE PRECISION me(n_i*n_j*n_k), mf(n_i*n_j*n_k)
+ DOUBLE PRECISION mg(n_i*n_j*n_k)
+ CHARACTER mbc_mask(n_i*n_j*n_k)
+
+! definitions of 'work' and 'locTMP'
+ INCLUDE 'pre_cg.inc'
+! use mod_blocking_size
+! locTMP : space for local vectors, using to exchange data with
+! 'matrix-vector-product'(MVP) and 'pre-conditioners'(L/R),
+! for definitions see more in 'pre_bicgstab.inc'
+
+! global buffer for boundary exchange
+ DOUBLE PRECISION bound_block(block_i*block_j+block_i*block_k+ &
+ block_j*block_k,bdim_i,bdim_j,bdim_k,2)
+ DOUBLE PRECISION dnrm(n_i*n_j*n_k)
+! private copy for preconditioning
+ DOUBLE PRECISION lma(max_blocks*block_i*block_j*block_k, &
+ tlevel_1)
+ DOUBLE PRECISION lmb(max_blocks*block_i*block_j*block_k, &
+ tlevel_1)
+ DOUBLE PRECISION lmc(max_blocks*block_i*block_j*block_k, &
+ tlevel_1)
+ DOUBLE PRECISION lmd(max_blocks*block_i*block_j*block_k, &
+ tlevel_1)
+ DOUBLE PRECISION lme(max_blocks*block_i*block_j*block_k, &
+ tlevel_1)
+ DOUBLE PRECISION lmf(max_blocks*block_i*block_j*block_k, &
+ tlevel_1)
+ DOUBLE PRECISION lmg(max_blocks*block_i*block_j*block_k, &
+ tlevel_1)
+ DOUBLE PRECISION lud(max_blocks*block_i*block_j*block_k, &
+ tlevel_1)
+ DOUBLE PRECISION lx(max_blocks*block_i*block_j*block_k, &
+ tlevel_1)
+ DOUBLE PRECISION lb(max_blocks*block_i*block_j*block_k, &
+ tlevel_1)
+ DOUBLE PRECISION ldnrm(max_blocks*block_i*block_j*block_k, &
+ tlevel_1)
+ DOUBLE PRECISION lloctmp(max_blocks*block_i*block_j*block_k, &
+ max_loctmp,tlevel_1)
+ DOUBLE PRECISION ud_block(block_i*block_j+block_i*block_k+ &
+ block_j*block_k,max_blocks,tlevel_1)
+
+! x,y,z-grid index for each block position
+ INTEGER, ALLOCATABLE :: xyz_block(:,:)
+ INTEGER lxyz_block, tid
+
+! Pre_CG stuff
+! work : control variable : what is to do out of this subroutine,
+! see more discription in 'pre_cg.inc',
+! on startup should set to 'work=START'
+ INTEGER work
+
+! break with enough precision
+ DOUBLE PRECISION depsilon
+
+ INTEGER xi, yi, zi, loc_mem, loc_memm1
+ INTEGER criteria, i, j, k, fkt_proza
+ EXTERNAL fkt_proza
+! openmp-private variables
+ INTEGER tpos, tanz
+! openmp-shared variables
+ INTEGER ipar(5), iii
+ DOUBLE PRECISION, ALLOCATABLE :: rpar(:)
+ INTEGER, ALLOCATABLE :: proza_lock(:,:,:)
+ LOGICAL lpar(1)
+
+
+! start values
+ work = start
+ res0 = 1.D+99
+
+ ALLOCATE(proza_lock(bdim_i,bdim_j,bdim_k))
+
+!$OMP parallel &
+!$OMP num_threads(Tlevel_1)&
+!$OMP default(none) shared(Tlevel_1, ismpl)&
+!$OMP shared(block_i,block_j,block_k, bdim_i,bdim_j,bdim_k,ipar,rpar)&
+!$OMP shared(N_I,N_J,N_K, depsilon, max_It, criteria, res0, work,lpar)&
+!$OMP shared(bound_block, MA,MB,MC,MD,ME,MF,MG,UD, x,b,ProzA_lock)&
+!$OMP shared(mbc_mask, dnrm, ud_block, ldnrm, max_blocks)&
+!$OMP shared(lMA,lMB,lMC,lMD,lUD,lME,lMF,lMG,lx,lb,llocTMP)&
+!$OMP private(i,j,k, tid, loc_mem,loc_memm1, lxyz_block, xyz_block)&
+!$OMP private(xi,yi,zi, iii, tpos, tanz)
+!$ call omp_binding(ismpl)
+
+ CALL omp_part(n_i*n_j*n_k,tpos,tanz)
+ tid = omp_get_his_thread_num() + 1
+
+!$OMP master
+ iii = 6 + 4*omp_get_num_of_threads()
+ ALLOCATE(rpar(iii))
+ CALL set_dval(iii,0.D0,rpar)
+! allocate(rpar(6 +4 *OMP_GET_NUM_of_THREADS()))
+ CALL par_reset(proza_lock)
+!$OMP end master
+! normalise the linear system, use [dnrm] to normalise the system
+ CALL norm_linsys(tanz,mbc_mask(tpos),b(tpos),x(tpos),ma(tpos), &
+ mb(tpos),mc(tpos),md(tpos),me(tpos),mf(tpos),mg(tpos), &
+ dnrm(tpos))
+!$OMP barrier
+! init ILU(0)-preconditioner, other start values
+ CALL prepare_ilu(n_i,n_j,n_k,ma,mb,mc,md,me,mf,mg,ud)
+
+! max number of private blocks = bdim_i*bdim_j*bdim_k
+ ALLOCATE(xyz_block(3,bdim_i*bdim_j*bdim_k))
+
+ lxyz_block = 0
+ DO k = 1, bdim_k
+ DO j = 1, bdim_j
+ DO i = 1, bdim_i
+ IF (fkt_proza(i,j,k)==tid-1) THEN
+! compute number of private blocks
+ lxyz_block = lxyz_block + 1
+! setup index information for each private block
+ xyz_block(1,lxyz_block) = i
+ xyz_block(2,lxyz_block) = j
+ xyz_block(3,lxyz_block) = k
+ END IF
+ END DO
+ END DO
+ END DO
+! memory requirements
+ loc_mem = lxyz_block*block_i*block_j*block_k
+ loc_memm1 = max_blocks*block_i*block_j*block_k
+
+! make private copies from the global arrays
+!$OMP barrier
+ CALL lcopy_ilu(n_i,n_j,n_k,ma,lma(1,tid),lxyz_block,xyz_block)
+ CALL lcopy_ilu(n_i,n_j,n_k,mb,lmb(1,tid),lxyz_block,xyz_block)
+ CALL lcopy_ilu(n_i,n_j,n_k,mc,lmc(1,tid),lxyz_block,xyz_block)
+ CALL lcopy_ilu(n_i,n_j,n_k,md,lmd(1,tid),lxyz_block,xyz_block)
+ CALL lcopy_ilu(n_i,n_j,n_k,ud,lud(1,tid),lxyz_block,xyz_block)
+ CALL lcopy_ilu(n_i,n_j,n_k,me,lme(1,tid),lxyz_block,xyz_block)
+ CALL lcopy_ilu(n_i,n_j,n_k,mf,lmf(1,tid),lxyz_block,xyz_block)
+ CALL lcopy_ilu(n_i,n_j,n_k,mg,lmg(1,tid),lxyz_block,xyz_block)
+ CALL lcopy_ilu(n_i,n_j,n_k,x,lx(1,tid),lxyz_block,xyz_block)
+ CALL lcopy_ilu(n_i,n_j,n_k,b,lb(1,tid),lxyz_block,xyz_block)
+ CALL lcopy_ilu(n_i,n_j,n_k,dnrm,ldnrm(1,tid),lxyz_block,xyz_block)
+! lcopy_ilu of [locTMP] not needed, but of the cleanup
+!aw-test Call set_dval(loC_memm1*max_loCTMP,0.d0,lloCTMP(1,1,tid))
+
+! copy private [UD] surface (position-1)
+ DO i = 1, lxyz_block
+ CALL lsurf_ilu(n_i,n_j,n_k,i,ud,ud_block(1,i,tid),lxyz_block,xyz_block)
+ END DO
+
+
+! INIT
+! preload ([M]x[x]) in [z]
+ CALL omp_mvp2(n_i,n_j,n_k,lxyz_block,lx(1,tid), &
+ lloctmp(1,s,tid),lma(1,tid),lmb(1,tid),lmc(1,tid), &
+ lmd(1,tid),lme(1,tid),lmf(1,tid),lmg(1,tid),bound_block, &
+ xyz_block)
+
+!**************************************************************
+
+10 CONTINUE
+
+! cg-routines without Pre-Cond.
+! step : is the return-lable for pre_cg()
+ CALL pre_cg(loc_mem,lx(1,tid),lb(1,tid),loc_memm1, &
+ lloctmp(1,1,tid),depsilon,ldnrm(1,tid),max_it,criteria,res0, &
+ work,ipar,rpar,lpar)
+! implicit barrier here
+
+ IF ((work==mvp) .OR. (work==mvpx)) THEN
+! solve: [M]x[z]=[r] -> [z]:=[A^-1]x[r]
+! here [M] can be a substituted Matrix [T] -> solve: [T]x[z]=[r]
+ CALL omp_lu_solve2(n_i,n_j,n_k,lxyz_block,lloctmp(1,r,tid), &
+ lloctmp(1,z,tid),lma(1,tid),lmb(1,tid),lmc(1,tid), &
+ lud(1,tid),lme(1,tid),lmf(1,tid),lmg(1,tid), &
+ ud_block(1,1,tid),bound_block,xyz_block,proza_lock)
+! need barrier here, [LU] and [MVP] modify "bound_block"
+!$OMP barrier
+! [s]:=[M]x[z]
+ CALL omp_mvp2(n_i,n_j,n_k,lxyz_block,lloctmp(1,z,tid), &
+ lloctmp(1,s,tid),lma(1,tid),lmb(1,tid),lmc(1,tid), &
+ lmd(1,tid),lme(1,tid),lmf(1,tid),lmg(1,tid),bound_block, &
+ xyz_block)
+ END IF
+
+! [v]:=[M]x[x], for advanced precision
+ IF (work==mvpx) THEN
+! need barrier here, both [MVP] modify "bound_block"
+!$OMP barrier
+ CALL omp_mvp2(n_i,n_j,n_k,lxyz_block,lx(1,tid), &
+ lloctmp(1,v,tid),lma(1,tid),lmb(1,tid),lmc(1,tid), &
+ lmd(1,tid),lme(1,tid),lmf(1,tid),lmg(1,tid),bound_block, &
+ xyz_block)
+ END IF
+
+
+! precision not enough ?
+ IF ((work/=fine) .AND. (work/=abort)) GO TO 10
+! at "work=ABORT", we can startup with a new [r^]
+
+!**************************************************************
+
+
+! get the global [x] from private
+ CALL lcopy_bak_ilu(n_i,n_j,n_k,x,lx(1,tid),lxyz_block,xyz_block)
+
+ DEALLOCATE(xyz_block)
+
+!$OMP end parallel
+ DEALLOCATE(rpar)
+ DEALLOCATE(proza_lock)
+
+ RETURN
+ END
diff --git a/solve/omp_sym_solve_ssor.f90 b/solve/omp_sym_solve_ssor.f90
new file mode 100644
index 0000000..d75e76b
--- /dev/null
+++ b/solve/omp_sym_solve_ssor.f90
@@ -0,0 +1,196 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief solve of : [M] x [x] = [b], CG algorithm based with SSOR preconditioning
+!> @param[in] N_I lengths of I dimension of local matrix [M]
+!> @param[in] N_J lengths of J dimension of local matrix [M]
+!> @param[in] N_K lengths of K dimension of local matrix [M]
+!> @param[in,out] x solution vector [x], on start = start vector
+!> @param[in] b right side, vector [b]
+!> @param[in] depsilon precision criteria to break iterations
+!> @param[in] mbc_mask boundary condition pattern (mask)
+!> @param[in] max_It max iteration number
+!> @param[in] criteria precision criteria mode to break iterations\n
+!> - 0 : relative stopping crit.: ||[res]|| < depsilon*||[res0]||\n
+!> - 1 : absolute stopping crit.: ||[res]|| < depsilon\n
+!> - 2 : maximum stopping crit.: max(abs([res])) < depsilon\n
+!> first [res]^=[r], later (if precise enough): [res]^=([M]x[x]-[b])
+!> @param[in] MA 1. diagonal of the system matrix [M]
+!> @param[in] MB 2. diagonal of the system matrix [M]
+!> @param[in] MC 3. diagonal of the system matrix [M]
+!> @param[in] MD 4. diagonal of the system matrix [M]
+!> @param[in] ME 5. diagonal of the system matrix [M]
+!> @param[in] MF 6. diagonal of the system matrix [M]
+!> @param[in] MG 7. diagonal of the system matrix [M]
+!> @param[out] locTMP local temporary vectors
+!> @param[out] dnrm normalisation vector, temporary use
+!> @param[in] ismpl local sample index
+!> @details
+!> solve of : [M] x [x] = [b]\n
+!> but here compute : [M^] x [x^] = [b^]\n
+!> [M] is s.p.d. Matrix, only used in 'ssor_MVP'\n
+!> Technics :\n
+!> - use reverse communication technics.\n
+!> each vector should be dense full without any hole,\n
+!> ( you can copy your elements from your structure to a \n
+!> temporary dense full vector, befor you use this algorithm \n
+!> and give the correct number of elements in 'N' ).\n
+!> if you have setup all vectors by a specific composition,\n
+!> each vector (x,b,r,...) on the same thread should use\n
+!> the same composition (same structure for all vectors on\n
+!> one thread).\n
+ SUBROUTINE omp_sym_solve_ssor(n_i,n_j,n_k,x,b,depsilon,mbc_mask, &
+ max_it,criteria,ma,mb,mc,md,me,mf,mg,loctmp,dnrm,ismpl)
+ use mod_OMP_TOOLS
+ use mod_blocking_size
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+
+! N : length of all vector x, r, z, s, b, p, q
+! ld_N : leading dimension of [locTMP]
+ INTEGER n, n_i, n_j, n_k, max_it, ismpl
+
+! thread stuff
+ INTEGER tanz, tpos
+
+! vector x and b for [M]x[x]=[b]
+! res0 ^= ||res0||, start residuel, given for 'criteria=0'
+ DOUBLE PRECISION x(n_i*n_j*n_k), b(n_i*n_j*n_k)
+ DOUBLE PRECISION res0
+ CHARACTER mbc_mask(n_i*n_j*n_k)
+ DOUBLE PRECISION ma(n_i*n_j*n_k), mb(n_i*n_j*n_k), &
+ mc(n_i*n_j*n_k)
+ DOUBLE PRECISION md(n_i*n_j*n_k), me(n_i*n_j*n_k), &
+ mf(n_i*n_j*n_k)
+ DOUBLE PRECISION mg(n_i*n_j*n_k)
+
+! definitions of 'work' and 'locTMP'
+ INCLUDE 'pre_cg.inc'
+! locTMP : space for local vectors, using to exchange data with
+! 'matrix-vector-product'(MVP) and 'pre-conditioners'(L/R),
+! for definitions see more in 'pre_bicgstab.inc'
+ DOUBLE PRECISION loctmp(n_i*n_j*n_k,max_loctmp)
+ DOUBLE PRECISION dnrm(n_i*n_j*n_k)
+
+! Pre_CG stuff
+! work : control variable : what is to do out of this subroutine,
+! see more discription in 'pre_cg.inc',
+! on startup should set to 'work=START'
+ INTEGER work
+
+! break with enough precision
+ DOUBLE PRECISION depsilon
+
+ INTEGER criteria
+! openmp-shared variables
+ INTEGER ipar(5), iii
+ DOUBLE PRECISION, ALLOCATABLE :: rpar(:)
+ LOGICAL lpar(1)
+
+
+! full number of elements
+ n = n_i*n_j*n_k
+ res0 = 1.D+99
+
+
+!**************************************************************
+
+! start values
+ work = start
+
+!$OMP parallel &
+!$OMP num_threads(Tlevel_1) &
+!$OMP default(shared) &
+!$OMP private(tanz,tpos,iii)
+!$ call omp_binding(ismpl)
+
+ CALL omp_part(n,tpos,tanz)
+
+!$OMP master
+ iii = 6 + 4*omp_get_num_of_threads()
+ ALLOCATE(rpar(iii))
+ CALL set_dval(iii,0.D0,rpar)
+! allocate(rpar(6 +4 *OMP_GET_NUM_of_THREADS()))
+!$OMP end master
+! normalise the linear system, use [dnrm] to normalise the system
+ CALL norm_linsys(tanz,mbc_mask(tpos),b(tpos),x(tpos),ma(tpos), &
+ mb(tpos),mc(tpos),md(tpos),me(tpos),mf(tpos),mg(tpos), &
+ dnrm(tpos))
+!$OMP barrier
+
+! ###################### not parallel Code !!! #########################
+! prepare [b^]
+! [b^] = D*(D+L)^(-1) * [b]
+ CALL ddl(n_i,n_j,n_k,b,loctmp(1,b_hat),ma,mb,mc,md)
+! ################### above not parallel Code !!! ######################
+
+! preload ([M]x[x]) in [s]
+ CALL ssor_mvp_single(n_i,n_j,n_k,x,loctmp(1,s),loctmp(1,mt), &
+ ma,mb,mc,md,me,mf,mg)
+! impliciete barrier here
+
+10 CONTINUE
+
+
+! cg-routines without Pre-Cond.
+! step : is the return-lable for pre_cg()
+ CALL pre_cg(tanz,x(tpos),loctmp(tpos,b_hat),n,loctmp(tpos,1), &
+ depsilon,dnrm(tpos),max_it,criteria,res0,work,ipar,rpar, &
+ lpar)
+! implicit barrier here
+
+ IF ((work==mvp) .OR. (work==mvpx)) THEN
+! solve: [M]x[z]=[r] -> [z]:=[A^-1]x[r]
+! here [M] can be a substituted Matrix [T] -> solve: [T]x[z]=[r]
+ CALL myprco(n,loctmp(1,r),loctmp(1,z))
+!$OMP barrier
+
+! [s]:=[M]x[z]
+ CALL ssor_mvp_single(n_i,n_j,n_k,loctmp(1,z),loctmp(1,s), &
+ loctmp(1,mt),ma,mb,mc,md,me,mf,mg)
+! implicit barrier here
+ END IF
+
+! [v]:=[M]x[x], for advanced precision
+ IF (work==mvpx) CALL ssor_mvp_single(n_i,n_j,n_k,x, &
+ loctmp(1,v),loctmp(1,mt),ma,mb,mc,md,me,mf,mg)
+! implicit barrier here
+
+
+! precision not enough ?
+ IF ((work/=fine) .AND. (work/=abort)) GO TO 10
+
+!$OMP end parallel
+
+! ###################### not parallel Code !!! #########################
+! compute [x]
+! [x] = (D+U)^(-1) * [x^]
+ CALL du(n_i,n_j,n_k,x,x,md,me,mf,mg)
+! ################### above not parallel Code !!! ######################
+
+ DEALLOCATE(rpar)
+
+!**************************************************************
+
+
+ RETURN
+ END
diff --git a/solve/p_pos_anz.f90 b/solve/p_pos_anz.f90
new file mode 100644
index 0000000..e99f734
--- /dev/null
+++ b/solve/p_pos_anz.f90
@@ -0,0 +1,101 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief gives start position for proc. 'my_rank'
+!> @param[in] N number of elements
+!> @param[in] my_rank my rank to part the vector (lengths given by N)
+!> @param[in] omp_P maximum rank to part the vector
+!> @return start position of elements for this rank
+ INTEGER FUNCTION ppos(n,my_rank,omp_p)
+ IMPLICIT NONE
+
+ INTEGER n
+! OMP stuff
+ INTEGER my_rank, rank, omp_p
+! tmp variables
+ INTEGER delta, schwelle, iall
+
+! checking border
+ rank = my_rank
+ IF (rank>(omp_p-1)) rank = omp_p - 1
+ IF (rank<0) rank = 0
+
+ delta = n/omp_p
+ schwelle = n - delta*omp_p
+ iall = delta*rank + rank + 1
+ IF ((rank+1)>schwelle) iall = iall + schwelle - rank
+
+ ppos = iall
+
+ RETURN
+ END
+
+!> @brief gives number of elements for proc. 'my_rank'
+!> @param[in] N number of elements
+!> @param[in] my_rank my rank to part the vector (lengths given by N)
+!> @param[in] omp_P maximum rank to part the vector
+!> @return number of elements for this rank
+ INTEGER FUNCTION panz(n,my_rank,omp_p)
+ IMPLICIT NONE
+
+ INTEGER n
+! OMP stuff
+ INTEGER rank, my_rank, omp_p
+! tmp variables
+ INTEGER delta, schwelle
+
+! checking border
+ rank = my_rank
+ IF (rank>(omp_p-1)) rank = omp_p - 1
+ IF (rank<0) rank = 0
+
+ delta = n/omp_p
+ schwelle = n - delta*omp_p
+ IF ((rank+1)<(schwelle+1)) delta = delta + 1
+
+ panz = delta
+
+ RETURN
+ END
+
+!> @brief compute position an number of local elements (OpenMP based)
+!> @param[in] N number of elements to parting
+!> @param[out] tpos start position of local elements
+!> @param[out] tanz local number of elements
+ SUBROUTINE omp_part(n,tpos,tanz)
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+
+ INTEGER n, panz, ppos
+ EXTERNAL panz, ppos
+! thread stuff
+ INTEGER tpos, tanz
+ INTEGER my_thd, thd_p
+
+ my_thd = omp_get_his_thread_num()
+ thd_p = omp_get_num_of_threads()
+ tanz = panz(n,my_thd,thd_p)
+ tpos = ppos(n,my_thd,thd_p)
+
+ RETURN
+ END
diff --git a/solve/par_tools.f90 b/solve/par_tools.f90
new file mode 100644
index 0000000..7b7a52b
--- /dev/null
+++ b/solve/par_tools.f90
@@ -0,0 +1,81 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief deallocate special solver staff, [proza]
+ SUBROUTINE par_end2()
+ use arrays
+ IMPLICIT NONE
+
+!$OMP master
+ DEALLOCATE(proza)
+!$OMP end master
+
+ RETURN
+ END
+
+!> @brief function wrapper for [proza_lock] - avoid side effects
+!> @param[in] ProzA_lock processor lock variable
+!> @return index of processor
+!> @details
+!> prove entry (locking)\n
+ INTEGER FUNCTION par_name(proza_lock)
+ IMPLICIT NONE
+ INTEGER proza_lock
+
+!$OMP flush(ProzA_lock)
+ par_name = proza_lock
+
+ RETURN
+ END
+
+!> @brief wrapper routine to set [proza_lock] - avoid side effects
+!> @param[out] ProzA_lock processor lock variable
+!> @details
+!> disable an entry (locking)\n
+ SUBROUTINE par_disab(proza_lock)
+ IMPLICIT NONE
+ INTEGER proza_lock
+
+ proza_lock = 1
+!$OMP flush(ProzA_lock)
+
+ RETURN
+ END
+
+!> @brief initialize/reset [proza_lock] - clean marker of already computed blocks
+!> @param[out] ProzA_lock processor lock variable
+ SUBROUTINE par_reset(proza_lock)
+ use mod_blocking_size
+ IMPLICIT NONE
+ INTEGER proza_lock(bdim_i,bdim_j,bdim_k)
+ INTEGER i, j, k
+
+ DO k = 1, bdim_k
+ DO j = 1, bdim_j
+ DO i = 1, bdim_i
+ proza_lock(i,j,k) = 0
+ END DO
+ END DO
+ END DO
+
+ RETURN
+ END
diff --git a/solve/pre_bicgstab.f90 b/solve/pre_bicgstab.f90
new file mode 100644
index 0000000..606e606
--- /dev/null
+++ b/solve/pre_bicgstab.f90
@@ -0,0 +1,580 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief compute the solution for [A]x[x]=[b], [A] general matrix
+!> @param[in] N number of elements, vector length, equal for all vectors
+!> @param[in,out] x starting-vector [x0], on exit = solution-vector [x]
+!> @param[in] b right side, vector [b]
+!> @param[in] r0_hat random vector [r0_hat] ^= [r0^]
+!> @param[in] ld_lv leading Dimension of 'locTMP'
+!> @param[in,out] locTMP space for local vectors, using to exchange data with\n
+!> 'matrix-vector-product'(MVP) and 'pre-conditioners'(L/R),\n
+!> for definitions see more in 'pre_bicgstab.inc'
+!> @param[in] depsilon precision criteria to break iterations
+!> @param[in] max_It maximum of iterations, counted with 'iter'
+!> @param[in] criteria precision criteria mode to break iterations\n
+!> - 0 : relative stopping crit.: ||[res]|| < depsilon*||[res0]||\n
+!> - 1 : absolute stopping crit.: ||[res]|| < depsilon\n
+!> - 2 : maximum stopping crit.: max(abs([res])) < depsilon\n
+!> first [res]^=[r], later (if precise enough): [res]^=([M]x[x]-[b])
+!> @param[in] res0 res0 ^= ||[res0]||, start residuel, given for 'criteria=0'
+!> @param[in,out] work control variable : what is to do out of this subroutine,\n
+!> see more discription in 'pre_bicgstab.inc',\n
+!> on startup should set to 'work=START'
+!> @param[in,out] dnrm normalisation vector, temporary use
+!> @param[out] ipar integer type help vector - OpenMP "shared"
+!> @param[out] rpar floating type point help vector - OpenMP "shared"
+!> @param[out] lpar logical type help vector - OpenMP "shared"
+!> @details
+!> compute the solution for [A]x[x]=[b], [A] general matrix\n
+!> make use of [K]=[L_K]*[R_K], [K] is preconditioner for [A]\n
+!> - [L_K] : left preconditioner (function : L_PrCo)\n
+!> - [R_K] : right preconditioner (function : R_PrCo)
+!>
+!> Technics :\n
+!> - use reverse communication technics.\n
+!> each vector should be dense full without any hole,\n
+!> ( you can copy your elements from your structure to a \n
+!> temporary dense full vector, befor you use this algorithm \n
+!> and give the correct number of elements in 'N' ).\n
+!> if you have setup all vectors by a specific composition,\n
+!> each vector (x,b,r,...) on the same thread should use\n
+!> the same composition (same structure for all vectors on\n
+!> one thread).
+!>
+!> BiCGStab algorithm :\n
+!> before begin : result of [A]x[x] should given in [z]-vector (see locTMP)\n
+!> 100 ----------- (... begin ...)\n
+!> - [r]:=[b]-[z] ^= [b]-[A]x[x]\n
+!> - abbruch(N,r,z,depsilon, ...) ? -> goto 400\n
+!> - sigma:=[r0_hat]^T*[r]\n
+!> - sigma = 0 ? -> aborting\n
+!> - rho:=alpha:=omega=1\n
+!> - [v]:=[p]:=0\n
+!> - beta:=(sigma/rho)*(alpha/omega)\n
+!> - rho:=sigma\n
+!> - [p]:=[r]+beta*([p]-omega*[v])
+!> - "solve [K]x[y]=[p]":\n
+!> - L_PrCo->[t_pc] [t_pc]:=[L_K^-1]x[p]\n
+!> - R_PrCo->[y] [y]:=[R_K^-1]x[t_pc]\n
+!> - "myMVP->[v]":\n
+!> - [v]:=[A]x[y]\n
+!>
+!> 200 ----------- (... iterations ...)\n
+!> - abbruch(N,r,z,depsilon, ...) ? -> goto 400\n
+!> - sigma:=[r0_hat]^T*[v]\n
+!> - alpha:=rho/sigma\n
+!> - [s]:=[r]-alpha*[v]\n
+!> - "solve [K]x[z]=[s]":\n
+!> - L_PrCo->[s_pc] [s_pc]:=[L_K^-1]x[s]\n
+!> - R_PrCo->[z] [z]:=[R_K^-1]x[s_pc]\n
+!> - "myMVP->[t]":\n
+!> - [t]:=[A]x[z]\n
+!> - L_PrCo->[t_pc] :[t_pc]:=[L_K^-1]x[t]\n
+!>
+!> 300 ----------- \n
+!> - omega:=[t_pc]^T*[s_pc]\n
+!> - sigma:=[t_pc]^T*[t_pc]\n
+!> - d1:=[r0_hat]^T*[s]\n
+!> - d2:=[r0_hat]^T*[t]\n
+!> - omega:=omega/sigma\n
+!> - [x]:=[x]+alpha*[y]+omega*[z]\n
+!> - [r]:=[s]-omega*[t]\n
+!> - sigma:=d1-omega*d2\n
+!> - sigma = 0 ? -> aborting\n
+!> - beta:=(sigma/rho)*(alpha/omega)\n
+!> - rho:=sigma\n
+!> - [p]:=[r]+beta*([p]-omega*[v])\n
+!> - "solve [K]x[y]=[p]":\n
+!> - L_PrCo->[t_pc] [t_pc]:=[L_K^-1]x[p]\n
+!> - R_PrCo->[y] [y]:=[R_K^-1]x[t_pc]\n
+!> - "myMVP->[v]":\n
+!> - [v]:=[A]x[y]\n
+!> - -> goto 200 (... iterations ...)\n
+!>
+!> 400 ----------- (... end ...)\n
+!> - -> END\n
+ SUBROUTINE pre_bicgstab(n,x,b,r0_hat,ld_lv,loctmp,depsilon,dnrm, &
+ max_it,criteria,res0,work,ipar,rpar,lpar)
+ use mod_OMP_TOOLS
+ use mod_linfos
+ use mod_blocking_size
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+
+! N : number of elements of all vector
+! ld_lv : leading Dimension for vectors in 'locTMP'
+ INTEGER n, ld_lv
+! vectors [x], [b], [r0_hat]
+ DOUBLE PRECISION x(max(n,1)), b(max(n,1))
+ DOUBLE PRECISION r0_hat(max(n,1)), dnrm(max(n,1))
+
+! temporary local variables
+ DOUBLE PRECISION sigma, beta, omega, res0, d1, d2, de
+
+! break with enough precision
+ DOUBLE PRECISION depsilon, p_e_old
+ INTEGER criteria, p_e_count
+
+! used external functions
+ LOGICAL omp_abbruch
+ EXTERNAL omp_abbruch
+
+! definitions of 'work' and 'locTMP'
+ INCLUDE 'pre_bicgstab.inc'
+ DOUBLE PRECISION loctmp(ld_lv,max_loctmp)
+
+! work : next Work to do
+ INTEGER work
+
+! max_It : max iterations
+ INTEGER max_it
+
+! first times [Ax]
+ INTEGER p_first_ax
+
+! private only for the master thread
+ INTEGER p_master
+
+ DOUBLE PRECISION d_one
+ PARAMETER (d_one=1.0D0)
+
+! blocking staff
+ INTEGER von, bis
+
+! for definitions of r,z,s,t,v,p,y,t_pc,s_pc and locTMP see in 'pre_bicgstab.inc'
+
+! p_* : temporary local private copy of *-variables
+ DOUBLE PRECISION p_rho, p_alpha
+ INTEGER p_iter, p_step, p_divide_zero
+ LOGICAL p_need_ax
+
+ INTRINSIC dsqrt
+
+! needing saved and shared variables
+! iter : count iterations, max_It : max iterations
+! step : jump-lable, next line to continue
+! divide_zero : control error level
+! first_Ax : first times [Ax]
+! need_Ax : switch to compute an extra MVP:([A]x[x]) in [z]
+! sh_help : openmp-shared space
+ INTEGER iiter, istep, idivide_zero, ie_count, ifirst_ax
+ INTEGER rrho, ralpha, re_old, rb_e_old, rsh_help, rsh_vhelp
+ INTEGER lneed_ax
+ PARAMETER (iiter=1,istep=2,idivide_zero=3,ie_count=4, &
+ ifirst_ax=5)
+ PARAMETER (rrho=1,ralpha=2,re_old=3,rb_e_old=4)
+! sh_vhelp needs [4*#threads] entries
+ PARAMETER (rsh_help=5,rsh_vhelp=6)
+ PARAMETER (lneed_ax=1)
+ INTEGER ipar(5)
+ DOUBLE PRECISION rpar(*)
+ LOGICAL lpar(1)
+! save iter, rho, alpha, need_Ax, step, divide_zero, e_count
+! save e_old, b_e_old, first_Ax
+
+
+! shared variables should be private ...
+ p_iter = ipar(iiter)
+ p_rho = rpar(rrho)
+ p_alpha = rpar(ralpha)
+ p_need_ax = lpar(lneed_ax)
+ p_step = ipar(istep)
+ p_divide_zero = ipar(idivide_zero)
+ p_e_count = ipar(ie_count)
+ p_e_old = rpar(re_old)
+ p_first_ax = ipar(ifirst_ax)
+ de = 2.0D0*rpar(rb_e_old)
+
+! jump-table
+ IF (work==start) GO TO 100
+ IF (p_step==200) GO TO 200
+ IF (p_step==300) GO TO 300
+
+ WRITE(*,'(A,I3,A)') ' error : no jump label ', p_step, &
+ ', startup value should be "work=START" !'
+ GO TO 400
+
+
+100 CONTINUE
+
+! need barrier here for fewer data races, because of the init part above
+!$OMP barrier
+! initialize some 'save'-variables at the beginning of a new system
+!aw p_iter = 0
+!aw p_need_Ax = .false.
+ p_divide_zero = 0
+
+ p_e_count = 0
+ p_e_old = 0.0D0
+ rpar(rb_e_old) = 1.0D99
+ de = 2.0D0*rpar(rb_e_old)
+ p_first_ax = 0
+
+! rho:=alpha:=omega=1
+! p_rho = d_one
+ p_alpha = d_one
+ omega = d_one
+
+! [r]:=[b]-[z] ^= [b]-[A]x[x]
+ CALL dcopy(n,b(1),1,loctmp(1,r),1)
+ CALL daxpy(n,-d_one,loctmp(1,z),1,loctmp(1,r),1)
+
+! abbruch(N,r,z,depsilon, ...) ? -> goto 400
+! temp. use of 'de' to prove precision
+ IF (criteria==2) THEN
+ CALL omp_damax(n,loctmp(1,r),de,rpar(rsh_help))
+ ELSE
+ CALL omp_ddot(n,loctmp(1,r),loctmp(1,r),de,rpar(rsh_vhelp))
+!$OMP master
+ res0 = dsqrt(de)
+!$OMP end master
+! need barrier here, because of the next DDOT (rpar-reuse)
+!$OMP barrier
+ END IF
+ p_need_ax = .TRUE.
+ p_iter = 1
+
+ IF (omp_abbruch(de,p_iter,max_it,depsilon,p_need_ax,criteria, &
+ res0,p_divide_zero,p_e_count,p_e_old)) GO TO 400
+
+! initialize some 'save'-variables at the beginning of a new system
+ p_need_ax = .FALSE.
+ p_iter = 0
+
+! sigma:=[r0_hat]^T*[r]
+! d1:=[b]^T*[b]; trivial solution test
+ CALL omp_2ddot(n,r0_hat(1),loctmp(1,r),sigma,b(1),b(1),d1, &
+ rpar(rsh_vhelp))
+! impliCit barrier here ...
+
+! sigma = 0 ? -> aborting, error
+ CALL test_zero(sigma,1,p_divide_zero)
+! d1 = 0 ? -> aborting, trivial solution
+ CALL test_zero(d1,7,p_divide_zero)
+ IF (p_divide_zero/=0) GO TO 400
+
+! beta:=(sigma/rho)*(alpha/omega)
+ beta = sigma
+
+! rho:=sigma
+ p_rho = sigma
+
+! [v]:=[p]:=0
+ CALL set_dval(n,0.D0,loctmp(1,v))
+ CALL set_dval(n,0.D0,loctmp(1,p))
+
+! [p]:=[r]+beta*([p]-omega*[v])
+ CALL daxpy(n,-omega,loctmp(1,v),1,loctmp(1,p),1)
+ CALL dscal(n,beta,loctmp(1,p),1)
+ CALL daxpy(n,d_one,loctmp(1,r),1,loctmp(1,p),1)
+
+! solve [K]x[y]=[p]:
+! L_PrCo->[t_pc] [t_pc]:=[L_K^-1]x[p]
+! R_PrCo->[y] [y]:=[R_K^-1]x[t_pc]
+! myMVP->[v] :[v]:=[A]x[y]
+
+! barrier above ...
+!$OMP master
+ work = do_y_p_v
+!$OMP end master
+ p_step = 200
+! no barrier here ... need barrier later ...
+
+ GO TO 1000
+
+
+200 CONTINUE
+
+! prepare values for 'omp_abbruch'-function
+! temp. use of 'de' to compute precision
+! test absulute residuel : ([b]-[A]x[x])
+! [A]x[x] is given in [z]
+ IF (p_need_ax) THEN
+ CALL daxpy(n,-d_one,b,1,loctmp(1,z),1)
+ CALL norm_resid(n,dnrm,x,loctmp(1,z))
+ END IF
+! impliCit barrier here ...
+ IF (criteria==2) THEN
+ IF (p_need_ax) THEN
+ CALL omp_damax(n,loctmp(1,z),de,rpar(rsh_help))
+ ELSE
+ CALL omp_damax(n,loctmp(1,r),de,rpar(rsh_help))
+ END IF
+! impliCit barrier here ...
+! sigma:=[r0_hat]^T*[v]
+ CALL omp_ddot(n,r0_hat(1),loctmp(1,v),sigma,rpar(rsh_vhelp))
+! impliCit barrier here ...
+ ELSE
+! sigma:=[r0_hat]^T*[v]
+! call omp_ddot(N,r0_hat(1),locTMP(1,v),sigma,rpar(Rsh_vhelp))
+ IF (p_need_ax) THEN
+ CALL omp_2ddot(n,loctmp(1,z),loctmp(1,z),de,r0_hat(1), &
+ loctmp(1,v),sigma,rpar(rsh_vhelp))
+! impliCit barrier here ...
+ ELSE
+ CALL omp_2ddot(n,loctmp(1,r),loctmp(1,r),de,r0_hat(1), &
+ loctmp(1,v),sigma,rpar(rsh_vhelp))
+! impliCit barrier here ...
+ END IF
+ END IF
+
+! abbruch(N,r,z,depsilon, ...) ? -> goto 400
+! temp. use of 'de' to prove precision
+ IF (omp_abbruch(de,p_iter,max_it,depsilon,p_need_ax,criteria, &
+ res0,p_divide_zero,p_e_count,p_e_old)) GO TO 400
+
+! sigma:=[r0_hat]^T*[v]
+! is compute above ...
+
+! error prevention
+ CALL test_zero(sigma,2,p_divide_zero)
+
+! alpha:=rho/sigma
+ p_alpha = p_rho/sigma
+
+
+! begin blocking
+ von = 1
+ bis = min(n,int(bl_size/bldiv_bicg(1)))
+1 CONTINUE
+
+! [s]:=[r]-alpha*[v]
+ CALL dcopy(bis-von+1,loctmp(von,r),1,loctmp(von,s),1)
+ CALL daxpy(bis-von+1,-p_alpha,loctmp(von,v),1,loctmp(von,s),1)
+
+! end blocking
+ von = bis + 1
+ bis = min(n,bis+int(bl_size/bldiv_bicg(1)))
+ IF (von<=n) GO TO 1
+
+
+! solve [K]x[z]=[s]:
+! L_PrCo->[s_pc] [s_pc]:=[L_K^-1]x[s]
+! R_PrCo->[z] [z]:=[R_K^-1]x[s_pc]
+! myMVP->[t] :[t]:=[A]x[z]
+! L_PrCo->[t_pc] :[t_pc]:=[L_K^-1]x[t]
+
+! barrier above ... (in omp_ddot)
+!$OMP master
+ work = do_z_s_t
+!$OMP end master
+ p_step = 300
+! no barrier here ... need barrier later ...
+
+ GO TO 1000
+
+
+300 CONTINUE
+
+! omega:=[t_pc]^T*[s_pc]
+! call omp_ddot(N,locTMP(1,t_pc),locTMP(1,s_pc),omega,rpar(Rsh_vhelp))
+
+! sigma:=[t_pc]^T*[t_pc]
+! call omp_ddot(N,locTMP(1,t_pc),locTMP(1,t_pc),sigma,rpar(Rsh_vhelp))
+
+! d1:=[r0_hat]^T*[s]
+! call omp_ddot(N,r0_hat(1),locTMP(1,s),d1,rpar(Rsh_vhelp))
+
+! d2:=[r0_hat]^T*[t]
+! call omp_ddot(N,r0_hat(1),locTMP(1,t),d2,rpar(Rsh_vhelp))
+
+
+ CALL omp_4ddot(n,loctmp(1,t_pc),loctmp(1,s_pc),omega, &
+ loctmp(1,t_pc),loctmp(1,t_pc),sigma,r0_hat(1),loctmp(1,s), &
+ d1,r0_hat(1),loctmp(1,t),d2,rpar(rsh_vhelp))
+! impliCit barrier here ...
+
+! error prevention
+ CALL test_zero(sigma,3,p_divide_zero)
+
+! omega:=omega/sigma
+ omega = omega/sigma
+
+! change computing order ...
+
+! sigma:=d1-omega*d2
+ sigma = d1 - omega*d2
+
+! sigma = 0 ? -> aborting
+ CALL test_zero(sigma,4,p_divide_zero)
+
+! error prevention
+ CALL test_zero(p_rho,5,p_divide_zero)
+ CALL test_zero(omega,6,p_divide_zero)
+
+! beta:=(sigma/rho)*(alpha/omega)
+ beta = (sigma*p_alpha)/(p_rho*omega)
+
+
+! begin blocking
+ von = 1
+ bis = min(n,int(bl_size/bldiv_bicg(2)))
+2 CONTINUE
+
+! [x]:=[x]+alpha*[y]+omega*[z]
+ CALL daxpy(bis-von+1,p_alpha,loctmp(von,y),1,x(von),1)
+ CALL daxpy(bis-von+1,omega,loctmp(von,z),1,x(von),1)
+
+! [r]:=[s]-omega*[t]
+ CALL dcopy(bis-von+1,loctmp(von,s),1,loctmp(von,r),1)
+ CALL daxpy(bis-von+1,-omega,loctmp(von,t),1,loctmp(von,r),1)
+
+! [p]:=[r]+beta*([p]-omega*[v])
+ CALL daxpy(bis-von+1,-omega,loctmp(von,v),1,loctmp(von,p),1)
+ CALL dscal(bis-von+1,beta,loctmp(von,p),1)
+ CALL daxpy(bis-von+1,d_one,loctmp(von,r),1,loctmp(von,p),1)
+
+! end blocking
+ von = bis + 1
+ bis = min(n,bis+int(bl_size/bldiv_bicg(2)))
+ IF (von<=n) GO TO 2
+
+
+! rho:=sigma
+ p_rho = sigma
+
+! iteration counting (+2 Matrix-Vector-Products)
+ p_iter = p_iter + 1
+
+! if division by zero detected, try to testing for good precision
+! can be disabled !!!
+ IF (p_divide_zero/=0) p_need_ax = .TRUE.
+
+! solve [K]x[y]=[p]:
+! L_PrCo->[t_pc] [t_pc]:=[L_K^-1]x[p]
+! R_PrCo->[y] [y]:=[R_K^-1]x[t_pc]
+! myMVP->[v] :[v]:=[A]x[y]
+
+!$OMP master
+ work = do_y_p_v
+
+! need a second MVP, compute ([A]x[x]) in [z]
+ IF (p_need_ax) work = more_y_p_v
+!$OMP end master
+ p_step = 200
+! no barrier here ... need barrier later ...
+
+ GO TO 1000
+
+
+400 CONTINUE
+
+! -> END
+
+! restore best [x] value
+ IF (rpar(rb_e_old)<p_e_old .AND. rpar(rb_e_old)<de) THEN
+ CALL dcopy(n,loctmp(1,best),1,x,1)
+! so "b_e_old" will not changed later by the master
+ p_e_old = rpar(rb_e_old)
+!$OMP master
+ IF (linfos(4)>=1) THEN
+ IF (criteria==2) THEN
+ WRITE(*,'(1A,1e20.13,1A)',advance='NO') ', {', &
+ rpar(rb_e_old), '}'
+ ELSE
+ WRITE(*,'(1A,1e20.13,1A)',advance='NO') ', {', &
+ dsqrt(rpar(rb_e_old)), '}'
+ END IF
+ END IF
+!$OMP end master
+ END IF
+
+! need barrier before ...
+!$OMP master
+ work = fine
+!$OMP end master
+ p_step = 0
+
+ IF (p_divide_zero/=0) THEN
+!$OMP master
+ work = abort
+ IF (p_divide_zero==1) THEN
+ WRITE(*,*) ' '
+ WRITE(*,'(A)') ' warning: ([r^]^T*[r]) near Null'
+ ELSE IF (p_divide_zero==7) THEN
+ IF (linfos(4)>=0) THEN
+ WRITE(*,*) ' '
+ WRITE(*,'(2A)') ' warning: trivial solution, no boundary'&
+ , ' condition different from zero defined'
+ END IF
+ ELSE
+ IF (linfos(4)>=0) THEN
+ WRITE(*,*) ' '
+ WRITE(*,'(A,I2)') ' warning: Division by zero with code:'&
+ , p_divide_zero
+ END IF
+ END IF
+!$OMP end master
+ END IF
+! no barrier here ... need it later ...
+
+!$OMP master
+ IF (linfos(4)>=1) THEN
+!$ write(*,'(1A,1I4)',ADVANCE='NO') ', ',OMP_GET_NUM_of_THREADS()
+!$ write(*,'(1A)',ADVANCE='NO') ' threads used'
+ IF (p_iter>max_it) THEN
+ WRITE(*,'(A,I5,A)') ', Number of Iterations: ', p_iter, &
+ ':MAXIMUM (BiCGStab)'
+ ELSE
+ WRITE(*,'(A,I5,A)') ', Number of Iterations: ', p_iter, &
+ ' (BiCGStab)'
+ END IF
+ END IF
+!$OMP end master
+
+1000 CONTINUE
+
+ IF (p_need_ax .AND. p_divide_zero==0 .AND. p_first_ax>=0) &
+ p_first_ax = p_first_ax + 1
+
+! save best [x] value
+ p_master = 0
+ IF (p_e_old<rpar(rb_e_old) .OR. p_first_ax==3) THEN
+! save [x]
+ CALL dcopy(n,x,1,loctmp(1,best),1)
+ IF (p_first_ax==3) p_first_ax = -1
+!$OMP master
+ p_master = 1
+!$OMP end master
+ END IF
+
+! Danger : here is an important syncronistaion for consistent view
+! of 'work' and all save variables on exit ...
+!$OMP barrier
+
+!$OMP master
+ IF (p_master==1) rpar(rb_e_old) = p_e_old
+! private variables should be shared to save ...
+ ipar(iiter) = p_iter
+ rpar(rrho) = p_rho
+ rpar(ralpha) = p_alpha
+ lpar(lneed_ax) = p_need_ax
+ ipar(istep) = p_step
+ ipar(idivide_zero) = p_divide_zero
+ ipar(ie_count) = p_e_count
+ rpar(re_old) = p_e_old
+ ipar(ifirst_ax) = p_first_ax
+!$OMP end master
+
+ RETURN
+ END
diff --git a/solve/pre_bicgstab.inc b/solve/pre_bicgstab.inc
new file mode 100644
index 0000000..6ff6e39
--- /dev/null
+++ b/solve/pre_bicgstab.inc
@@ -0,0 +1,86 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!
+! K=L_K*R_K : preconditioner
+!
+! Constant : aborting, ([r0_hat]^T*[r])=0
+ integer ABORT
+!
+! Constant : at the beginning of a new system
+ integer START
+!
+! Constant : preconditioner [y]:=[K^-1]x[p],
+! matrix-vector product [v]:=[A]x[y]
+ integer Do_y_p_v
+!
+! Constant : preconditioner [z]:=[K^-1]x[s],
+! preconditioner [s_pc]:=[L_K^-1]x[s],
+! matrix-vector product [t]:=[A]x[z],
+! preconditioner [t_pc]:=[L_K^-1]x[t]
+ integer Do_z_s_t
+!
+! Constant : preconditioner [y]:=[K^-1]x[p],
+! matrix-vector product [v]:=[A]x[y],
+! matrix-vector product [z]:=[A]x[x] for advanced precision
+ integer more_y_p_v
+!
+! Constant : nothing to do anymore ...
+ integer FINE
+!
+ parameter (ABORT =-1)
+ parameter (START = 0)
+ parameter (Do_y_p_v = 1)
+ parameter (Do_z_s_t = 2)
+ parameter (more_y_p_v = 3)
+ parameter (FINE = 4)
+
+!
+! offsets for temporary vectors saved in [locTMP]
+! ld_lv : leading dimension (local number of elements)
+! locTMP(1,1) ^= [b_hat] (only for EST)
+! locTMP(1,2) ^= [r0_tilde] (only for EST)
+! locTMP(1,3) ^= [r]
+! locTMP(1,4) ^= [z]
+! locTMP(1,5) ^= [s]
+! locTMP(1,6) ^= [t]
+! locTMP(1,7) ^= [v]
+! locTMP(1,8) ^= [p]
+! locTMP(1,9) ^= [y]
+! locTMP(1,10) ^= [t_pc]
+! locTMP(1,11) ^= [s_pc]
+! locTMP(1,12)^= [mt] (only for EST)
+! locTMP(1,13)^= [best] X value
+ integer b_hat,r0_tilde,r,z,s,t,v,p,y,t_pc,s_pc,mt,best
+ parameter(b_hat=1)
+ parameter(r0_tilde=2)
+ parameter(r=3)
+ parameter(z=4)
+ parameter(s=5)
+ parameter(t=6)
+ parameter(v=7)
+ parameter(p=8)
+ parameter(y=9)
+ parameter(t_pc=10)
+ parameter(s_pc=11)
+ parameter(mt=12)
+ parameter(best=13)
diff --git a/solve/pre_cg.f90 b/solve/pre_cg.f90
new file mode 100644
index 0000000..5995ff0
--- /dev/null
+++ b/solve/pre_cg.f90
@@ -0,0 +1,540 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief compute the solution for [A]x[x]=[b], [A] sym.pos.def. matrix
+!> @param[in] N number of elements, vector length, equal for all vectors
+!> @param[in,out] x starting-vector [x0], on exit = solution-vector [x]
+!> @param[in] b right side, vector [b]
+!> @param[in] ld_lv leading Dimension of 'locTMP'
+!> @param[in,out] locTMP space for local vectors, using to exchange data with\n
+!> 'matrix-vector-product'(MVP) and 'pre-conditioners'(L/R),\n
+!> for definitions see more in 'pre_bicgstab.inc'
+!> @param[in] depsilon precision criteria to break iterations
+!> @param[in] max_It maximum of iterations, counted with 'iter'
+!> @param[in] criteria precision criteria mode to break iterations\n
+!> - 0 : relative stopping crit.: ||[res]|| < depsilon*||[res0]||\n
+!> - 1 : absolute stopping crit.: ||[res]|| < depsilon\n
+!> - 2 : maximum stopping crit.: max(abs([res])) < depsilon\n
+!> first [res]^=[r], later (if precise enough): [res]^=([M]x[x]-[b])
+!> @param[in] res0 res0 ^= ||[res0]||, start residuel, given for 'criteria=0'
+!> @param[in,out] work control variable : what is to do out of this subroutine,\n
+!> see more discription in 'pre_bicgstab.inc',\n
+!> on startup should set to 'work=START'
+!> @param[in,out] dnrm normalisation vector, temporary use
+!> @param[out] ipar integer type help vector - OpenMP "shared"
+!> @param[out] rpar floating type point help vector - OpenMP "shared"
+!> @param[out] lpar logical type help vector - OpenMP "shared"
+!> @details
+!> compute the solution for [A]x[x]=[b], [A] sym.pos.def. matrix\n
+!> make use of [K] as a preconditioner for [A], (function : myPrCo)\n
+!> Technics :20;\n
+!> - use reverse communication technics.\n
+!> each vector should be dense full without any hole,\n
+!> ( you can copy your elements from your structure to a \n
+!> temporary dense full vector, befor you use this algorithm \n
+!> and give the correct number of elements in 'N' ).\n
+!> if you have setup all vectors by a specific composition,\n
+!> each vector (x,b,r,...) on the same thread should use\n
+!> the same composition (same structure for all vectors on\n
+!> one thread).
+!>
+!> CG algorithm :\n
+!> before begin : result of [A]x[x] should given in [s]-vector (see locTMP)\n
+!> 100 ----------- (... begin ...)\n
+!> - [r]:=[b]-[s]\n
+!> - abbruch(N,r,depsilon, ...) ? -> goto 400\n
+!> - [p]:=[q]:=0\n
+!> - beta:=0\n
+!> - "solve [K][z]=[r]":\n
+!> - myPrCo->[z] [z]:=[K^-1]x[r]\n
+!> - "myMVP->[s]":\n
+!> - [s]:=[A]x[z]\n
+!>
+!> 200 ----------- \n
+!> - sigma:=([r]^T*[z])\n
+!> - mu:=([s]^T*[z])\n
+!> - alpha:=sigma/mu\n
+!> - [p]:=[z]+beta*[p]\n
+!> - [q]:=[s]+beta*[q]\n
+!> - [x]:=[x]+alpha*[p]\n
+!> - [r]:=[r]-alpha*[q]\n
+!> - "solve [K][z]=[r]":\n
+!> - myPrCo->[z] [z]:=[K^-1]x[r]\n
+!> - "myMVP->[s]":\n
+!> - [s]:=[A]x[z]\n
+!>
+!> 300 ----------- (... iterations ...)\n
+!> - abbruch(N,r,depsilon, ...) ? -> goto 400\n
+!> - sigma_new:=([r]^T*[z])\n
+!> - mu:=([s]^T*[z])\n
+!> - beta:=sigma_new/sigma\n
+!> - sigma:=sigma_new\n
+!> - alpha:=sigma/(mu-sigma*beta/alpha)\n
+!> - [p]:=[z]+beta*[p]\n
+!> - [q]:=[s]+beta*[q]\n
+!> - [x]:=[x]+alpha*[p]\n
+!> - [r]:=[r]-alpha*[q]\n
+!> - "solve [K][z]=[r]":\n
+!> - myPrCo->[z] [z]:=[K^-1]x[r]\n
+!> - "myMVP->[s]":\n
+!> - [s]:=[A]x[z]\n
+!> - -> goto 300 (... iterations ...)\n
+!>
+!> 400 ----------- (... end ...)\n
+!> - -> END\n
+ SUBROUTINE pre_cg(n,x,b,ld_lv,loctmp,depsilon,dnrm,max_it, &
+ criteria,res0,work,ipar,rpar,lpar)
+ use mod_OMP_TOOLS
+ use mod_linfos
+ use mod_blocking_size
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+
+! N : number of elements of all vector
+! ld_lv : leading Dimension for vectors in 'locTMP'
+ INTEGER n, ld_lv
+! vectors [x], [b]
+ DOUBLE PRECISION x(max(n,1)), b(max(n,1)), dnrm(max(n,1))
+
+! temporary local variables
+ DOUBLE PRECISION mu, sigma_new, enough, res0
+
+! break with enough precision
+ DOUBLE PRECISION depsilon, p_e_old
+ INTEGER criteria, p_e_count
+
+! used external functions
+ LOGICAL omp_abbruch
+ EXTERNAL omp_abbruch
+
+! definitions of 'work' and 'locTMP'
+ INCLUDE 'pre_cg.inc'
+ DOUBLE PRECISION loctmp(ld_lv,max_loctmp)
+
+! work : next Work to do
+ INTEGER work
+
+! max_It : max iterations
+ INTEGER max_it
+
+! first times [Ax]
+ INTEGER p_first_ax
+
+! private only for the master thread
+ INTEGER p_master
+
+ DOUBLE PRECISION d_one, dzero
+ PARAMETER (d_one=1.0D0,dzero=0.0D0)
+
+! blocking staff
+ INTEGER von, bis
+
+! for definitions of r,z,s,p,q,v and locTMP see in 'pre_cg.inc'
+
+! p_* : temporary local private copy of *-variables
+ DOUBLE PRECISION p_beta, p_sigma, p_alpha
+ INTEGER p_iter, p_step, p_divide_zero
+ LOGICAL p_need_ax
+
+ INTRINSIC dsqrt
+
+! needing saved and shared variables
+! iter : count iterations, max_It : max iterations
+! step : jump-lable, next line to continue
+! divide_zero : control error level
+! first_Ax : first times [Ax]
+! need_Ax : switch to compute an extra MVP:([A]x[x]) in [z]
+! sh_help : openmp-shared space
+ INTEGER iiter, istep, idivide_zero, ie_count, ifirst_ax
+ INTEGER rbeta, rsigma, ralpha, re_old, rb_e_old, rsh_help, &
+ rsh_vhelp
+ INTEGER lneed_ax
+ PARAMETER (iiter=1,istep=2,idivide_zero=3,ie_count=4, &
+ ifirst_ax=5)
+ PARAMETER (rbeta=1,rsigma=2,ralpha=3,re_old=4,rb_e_old=5)
+! sh_vhelp needs [4*#threads] entries
+ PARAMETER (rsh_help=6,rsh_vhelp=7)
+ PARAMETER (lneed_ax=1)
+ INTEGER ipar(5)
+ DOUBLE PRECISION rpar(*)
+ LOGICAL lpar(1)
+! save iter, need_Ax, step, divide_zero, beta, sigma, alpha
+! save e_Count, e_old, b_e_old, first_Ax
+
+
+! shared variables should be private ...
+ p_iter = ipar(iiter)
+ p_need_ax = lpar(lneed_ax)
+ p_step = ipar(istep)
+ p_divide_zero = ipar(idivide_zero)
+ p_beta = rpar(rbeta)
+ p_sigma = rpar(rsigma)
+ p_alpha = rpar(ralpha)
+ p_e_count = ipar(ie_count)
+ p_e_old = rpar(re_old)
+ p_first_ax = ipar(ifirst_ax)
+ enough = 2.0D0*rpar(rb_e_old)
+
+! jump-table
+ IF (work==start) GO TO 100
+ IF (p_step==200) GO TO 200
+ IF (p_step==300) GO TO 300
+
+ WRITE(*,*) &
+ 'error : no jump lable, startup value should work=START'
+ GO TO 400
+
+
+100 CONTINUE
+
+! need barrier here for fewer data races, because of the init above ...
+!$OMP barrier
+! initialize some 'save'-variables at the beginning of a new system
+!aw p_iter = 0
+!aw p_need_Ax = .false.
+ p_divide_zero = 0
+
+ p_e_count = 0
+ p_e_old = 0.0D0
+ rpar(rb_e_old) = 1.0D99
+ enough = 2.0D0*rpar(rb_e_old)
+ p_first_ax = 0
+
+! beta:=0
+ p_beta = dzero
+
+! [r]:=[b]-[s]
+ CALL dcopy(n,b(1),1,loctmp(1,r),1)
+ CALL daxpy(n,-d_one,loctmp(1,s),1,loctmp(1,r),1)
+
+! abbruch(iter,r,depsilon, ...) ? -> goto 400
+! temp. use of 'enough' to prove precision
+ IF (criteria==2) THEN
+ CALL omp_damax(n,loctmp(1,r),enough,rpar(rsh_help))
+ ELSE
+ CALL omp_ddot(n,loctmp(1,r),loctmp(1,r),enough, &
+ rpar(rsh_vhelp))
+ res0 = dsqrt(enough)
+ END IF
+ p_need_ax = .TRUE.
+ p_iter = 1
+ IF (omp_abbruch(enough,p_iter,max_it,depsilon,p_need_ax, &
+ criteria,res0,p_divide_zero,p_e_count,p_e_old)) GO TO 400
+
+! initialize some 'save'-variables at the beginning of a new system
+ p_need_ax = .FALSE.
+ p_iter = 0
+
+! [p]:=[q]:=0
+ CALL set_dval(n,0.D0,loctmp(1,p))
+ CALL set_dval(n,0.D0,loctmp(1,q))
+
+! mu:= [b]^T*[b], trivial solution test
+ CALL omp_ddot(n,b(1),b(1),mu,rpar(rsh_vhelp))
+
+! mu = 0 ? aborting, trivial solution
+ CALL test_zero(mu,4,p_divide_zero)
+ IF (p_divide_zero/=0) GO TO 400
+
+! solve [K][z]=[r]:
+! myPrCo->[z] [z]:=[K^-1]x[r]
+! myMVP->[s] :[s]:=[A]x[z]
+
+! barrier above ...
+!$OMP master
+ work = mvp
+!$OMP end master
+ p_step = 200
+! no barrier here ... need barrier later ...
+
+ GO TO 1000
+
+
+200 CONTINUE
+
+! sigma:=([r]^T*[z])
+! call omp_ddot(N,locTMP(1,r),locTMP(1,z),sigma,rpar(Rsh_vhelp))
+
+! mu:=([s]^T*[z])
+! call omp_ddot(N,locTMP(1,s),locTMP(1,z),mu,rpar(Rsh_vhelp))
+
+ CALL omp_2ddot(n,loctmp(1,r),loctmp(1,z),p_sigma,loctmp(1,s), &
+ loctmp(1,z),mu,rpar(rsh_vhelp))
+! implicit barrier here ...
+
+! error prevention
+ CALL test_zero(mu,1,p_divide_zero)
+
+! alpha:=sigma/mu
+ p_alpha = p_sigma/mu
+
+! [p]:=[z]+beta*[p]
+ CALL dscal(n,p_beta,loctmp(1,p),1)
+ CALL daxpy(n,d_one,loctmp(1,z),1,loctmp(1,p),1)
+
+! [q]:=[s]+beta*[q]
+ CALL dscal(n,p_beta,loctmp(1,q),1)
+ CALL daxpy(n,d_one,loctmp(1,s),1,loctmp(1,q),1)
+
+! [x]:=[x]+alpha*[p]
+ CALL daxpy(n,p_alpha,loctmp(1,p),1,x(1),1)
+
+! [r]:=[r]-alpha*[q]
+ CALL daxpy(n,-p_alpha,loctmp(1,q),1,loctmp(1,r),1)
+
+! solve [K][z]=[r]:
+! myPrCo->[z] [z]:=[K^-1]x[r]
+! myMVP->[s] :[s]:=[A]x[z]
+
+!$OMP barrier
+! need barrier here ...
+!$OMP master
+ work = mvp
+!$OMP end master
+ p_step = 300
+! no barrier here ... need barrier later ...
+
+ GO TO 1000
+
+
+300 CONTINUE
+
+! preparing values for 'omp_abbruch'-function
+! temp. use of 'enough' to compute precision
+ IF (p_need_ax) THEN
+! test absulute residuel : ([b]-[A]x[x])
+! [A]x[x] is given in [v]
+! compute ([A]x[x]-[b]) instead above
+ CALL daxpy(n,-d_one,b,1,loctmp(1,v),1)
+ CALL norm_resid(n,dnrm,x,loctmp(1,v))
+ IF (criteria==2) THEN
+ CALL omp_damax(n,loctmp(1,v),enough,rpar(rsh_help))
+! implicit barrier here ...
+
+! sigma_new:=([r]^T*[z])
+! mu:=([s]^T*[z])
+ CALL omp_2ddot(n,loctmp(1,r),loctmp(1,z),sigma_new, &
+ loctmp(1,s),loctmp(1,z),mu,rpar(rsh_vhelp))
+! implicit barrier here ...
+ ELSE
+! call omp_ddot(N,locTMP(1,v),locTMP(1,v),enough,rpar(Rsh_vhelp))
+
+! sigma_new:=([r]^T*[z])
+! mu:=([s]^T*[z])
+ CALL omp_3ddot(n,loctmp(1,v),loctmp(1,v),enough, &
+ loctmp(1,r),loctmp(1,z),sigma_new,loctmp(1,s), &
+ loctmp(1,z),mu,rpar(rsh_vhelp))
+! implicit barrier here ...
+ END IF
+ ELSE
+! test [r] instead of residuel
+ IF (criteria==2) THEN
+ CALL omp_damax(n,loctmp(1,r),enough,rpar(rsh_help))
+! implicit barrier here ...
+
+! sigma_new:=([r]^T*[z])
+! mu:=([s]^T*[z])
+ CALL omp_2ddot(n,loctmp(1,r),loctmp(1,z),sigma_new, &
+ loctmp(1,s),loctmp(1,z),mu,rpar(rsh_vhelp))
+! implicit barrier here ...
+ ELSE
+! call omp_ddot(N,locTMP(1,r),locTMP(1,r),enough,rpar(Rsh_vhelp))
+
+! sigma_new:=([r]^T*[z])
+! mu:=([s]^T*[z])
+ CALL omp_3ddot(n,loctmp(1,r),loctmp(1,r),enough, &
+ loctmp(1,r),loctmp(1,z),sigma_new,loctmp(1,s), &
+ loctmp(1,z),mu,rpar(rsh_vhelp))
+! implicit barrier here ...
+ END IF
+ END IF
+
+! abbruch(iter,r,depsilon, ...) ? -> goto 400
+! temp. use of 'enough' to prove precision
+ IF (omp_abbruch(enough,p_iter,max_it,depsilon,p_need_ax, &
+ criteria,res0,p_divide_zero,p_e_count,p_e_old)) GO TO 400
+
+! sigma_new:=([r]^T*[z])
+! is compute above ...
+
+! mu:=([s]^T*[z])
+! is compute above ...
+
+! error prevention
+ CALL test_zero(p_sigma,2,p_divide_zero)
+
+! beta:=sigma_new/sigma
+ p_beta = sigma_new/p_sigma
+
+! sigma:=sigma_new
+ p_sigma = sigma_new
+
+! alpha:=sigma/(mu-sigma*beta/alpha)
+ p_alpha = mu - p_sigma*p_beta/p_alpha
+
+! error prevention
+ CALL test_zero(p_alpha,3,p_divide_zero)
+
+ p_alpha = p_sigma/p_alpha
+
+! iteration counting
+ p_iter = p_iter + 1
+
+
+! begin blocking
+ von = 1
+ bis = min(n,int(bl_size/bldiv_cg))
+1 CONTINUE
+
+! [p]:=[z]+beta*[p]
+ CALL dscal(bis-von+1,p_beta,loctmp(von,p),1)
+ CALL daxpy(bis-von+1,d_one,loctmp(von,z),1,loctmp(von,p),1)
+
+! [q]:=[s]+beta*[q]
+ CALL dscal(bis-von+1,p_beta,loctmp(von,q),1)
+ CALL daxpy(bis-von+1,d_one,loctmp(von,s),1,loctmp(von,q),1)
+
+! [x]:=[x]+alpha*[p]
+ CALL daxpy(bis-von+1,p_alpha,loctmp(von,p),1,x(von),1)
+
+! [r]:=[r]-alpha*[q]
+ CALL daxpy(bis-von+1,-p_alpha,loctmp(von,q),1,loctmp(von,r),1)
+
+! end blocking
+ von = bis + 1
+ bis = min(n,bis+int(bl_size/bldiv_cg))
+ IF (von<=n) GO TO 1
+
+
+! solve [K][z]=[r]:
+! myPrCo->[z] [z]:=[K^-1]x[r]
+! myMVP->[s] :[s]:=[A]x[z]
+
+! barrier above ... (in omp_ddot)
+!$OMP master
+ work = mvp
+! need a second MVP, compute ([A]x[x]) in [z]
+ IF (p_need_ax) work = mvpx
+!$OMP end master
+ p_step = 300
+! no barrier here ... need barrier later ...
+
+ GO TO 1000
+
+
+400 CONTINUE
+
+! -> END
+
+! restore best [x] value
+ IF (rpar(rb_e_old)<p_e_old .AND. rpar(rb_e_old)<enough) THEN
+ CALL dcopy(n,loctmp(1,best),1,x,1)
+! so "b_e_old" will not changed later by the master
+ p_e_old = rpar(rb_e_old)
+!$OMP master
+ IF (linfos(4)>=1) THEN
+ IF (criteria==2) THEN
+ WRITE(*,'(1A,1e20.13,1A)',advance='NO') ', {', &
+ rpar(rb_e_old), '}'
+ ELSE
+ WRITE(*,'(1A,1e20.13,1A)',advance='NO') ', {', &
+ dsqrt(rpar(rb_e_old)), '}'
+ END IF
+ END IF
+!$OMP end master
+ END IF
+
+! need barrier before ...
+!$OMP master
+ work = fine
+!$OMP end master
+ p_step = 0
+
+ IF (p_divide_zero/=0) THEN
+!$OMP master
+ work = abort
+ IF (linfos(4)>=0) THEN
+ IF (p_divide_zero==4) THEN
+ WRITE(*,*) ' '
+ WRITE(*,'(2A)') ' warning: trivial solution, no boundary'&
+ , ' condition different from zero'
+ ELSE
+ WRITE(*,*) ' '
+ WRITE(*,'(A,I2)') ' warning: Division by zero with code:'&
+ , p_divide_zero
+ END IF
+ END IF
+!$OMP end master
+ END IF
+! no barrier here ... need it later ...
+
+!$OMP master
+ IF (linfos(4)>=1) THEN
+!$ write(*,'(1A,1I4)',ADVANCE='NO') ', ',OMP_GET_NUM_of_THREADS()
+!$ write(*,'(1A)',ADVANCE='NO') ' threads used'
+ IF (p_iter>max_it) THEN
+ WRITE(*,'(A,I5,A)') ', Number of Iterations: ', p_iter, &
+ ':MAXIMUM (CG)'
+ ELSE
+ WRITE(*,'(A,I5,A)') ', Number of Iterations: ', p_iter, &
+ ' (CG)'
+ END IF
+ END IF
+!$OMP end master
+
+1000 CONTINUE
+
+ IF (p_need_ax .AND. p_divide_zero==0 .AND. p_first_ax>=0) &
+ p_first_ax = p_first_ax + 1
+
+! save best [x] value
+ p_master = 0
+ IF (p_e_old<rpar(rb_e_old) .OR. p_first_ax==3) THEN
+! save [x]
+ CALL dcopy(n,x,1,loctmp(1,best),1)
+ IF (p_first_ax==3) p_first_ax = -1
+!$OMP master
+ p_master = 1
+!$OMP end master
+ END IF
+
+! Danger : here is an important syncronistaion for consistent view
+! of 'work' and all save variables on exit ...
+!$OMP barrier
+
+!$OMP master
+ IF (p_master==1) rpar(rb_e_old) = p_e_old
+! private variables should be shared to save ...
+ ipar(iiter) = p_iter
+ lpar(lneed_ax) = p_need_ax
+ ipar(istep) = p_step
+ ipar(idivide_zero) = p_divide_zero
+ rpar(rbeta) = p_beta
+ rpar(rsigma) = p_sigma
+ rpar(ralpha) = p_alpha
+ ipar(ie_count) = p_e_count
+ rpar(re_old) = p_e_old
+ ipar(ifirst_ax) = p_first_ax
+!$OMP end master
+
+ RETURN
+ END
diff --git a/solve/pre_cg.inc b/solve/pre_cg.inc
new file mode 100644
index 0000000..76642a8
--- /dev/null
+++ b/solve/pre_cg.inc
@@ -0,0 +1,66 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!
+! Constant : at the beginning of a new system
+ integer START
+!
+! Constant : Matrix-Vector-Product [v]:=[A]x[s]
+ integer MVP
+!
+! Constant : two Matrix-Vector-Product [v]:=[A]x[s] & [z]:=[A]x[x]
+ integer MVPx
+!
+! Constant : nothing to do anymore ...
+ integer FINE
+!
+! Constant : must break
+ integer ABORT
+!
+ parameter (START = 0)
+ parameter (MVP = 1)
+ parameter (MVPx = 2)
+ parameter (FINE = 3)
+ parameter (ABORT = 4)
+
+!
+! offsets for temporary vectors saved in [locTMP]
+! ld_lv : leading dimensions (lokal number of elements)
+! locTMP(1,1) ^= [b_hat]
+! locTMP(1,2) ^= [r]
+! locTMP(1,3) ^= [z]
+! locTMP(1,4) ^= [s]
+! locTMP(1,5) ^= [p]
+! locTMP(1,6) ^= [q]
+! locTMP(1,7) ^= [v]
+! locTMP(1,8) ^= [mt] (only for EST)
+! locTMP(1,9) ^= [best] X value
+ integer b_hat,r,z,s,p,q,v,mt,best
+ parameter(b_hat=1)
+ parameter(r=2)
+ parameter(z=3)
+ parameter(s=4)
+ parameter(p=5)
+ parameter(q=6)
+ parameter(v=7)
+ parameter(mt=8)
+ parameter(best=9)
diff --git a/solve/preconditioners.f90 b/solve/preconditioners.f90
new file mode 100644
index 0000000..7a33035
--- /dev/null
+++ b/solve/preconditioners.f90
@@ -0,0 +1,76 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief preconditioner "dummy" routine, no preconditioning (copy instead)
+!> @param[in] N length of all vectors
+!> @param[in] r vector [r]
+!> @param[out] z vector [z]
+!> @details
+!> compute [z], the solution of [K]x[z]=[r]\n
+!> [K] is substitude from [A] and work as a preconditioner\n
+!> here simple example : only copy [z]:=[r]\n
+ SUBROUTINE myprco(n,r,z)
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+! N : length of all vectors r,z
+ INTEGER n
+! vectors [r], [z]
+ DOUBLE PRECISION r(*), z(*)
+! thread-stuff
+ INTEGER tpos, tanz
+
+ CALL omp_part(n,tpos,tanz)
+! very simple Pre-Cond.
+ CALL dcopy(tanz,r(tpos),1,z(tpos),1)
+ RETURN
+ END
+
+!> @brief simple diagonal preconditioner
+!> @param[in] N length of all vectors
+!> @param[in] r vector [r]
+!> @param[in] D diagonal vector for preconditioning
+!> @param[out] z vector [z]
+!> @details
+!> compute [z], the solution of [K]x[z]=[r]\n
+!> [K] is substitude from [A] and work as a preconditioner\n
+!> here simple example : [z]:=[r]/[d]\n
+ SUBROUTINE diagprco(n,d,r,z)
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+! N : length of all vectors r,z
+ INTEGER n, i
+! vectors [r], [z]
+ DOUBLE PRECISION r(n), z(n), d(n)
+! thread-stuff
+ INTEGER tpos, tanz
+
+ CALL omp_part(n,tpos,tanz)
+! works if there are not NULL-elements in [D]
+! very simple Pre-Cond.
+ DO i = tpos, tpos + tanz - 1
+!AW z(i)=r(i)/D(i)
+ IF (d(i)/=0.0D0) z(i) = r(i)/d(i)
+ END DO
+ RETURN
+ END
diff --git a/solve/prepare_solve.f90 b/solve/prepare_solve.f90
new file mode 100644
index 0000000..82ea88b
--- /dev/null
+++ b/solve/prepare_solve.f90
@@ -0,0 +1,317 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief setup ILU(0) preconditioner diagonal [UD]
+!> @param[in] NI lengths of I dimension of local matrix [M]
+!> @param[in] NJ lengths of J dimension of local matrix [M]
+!> @param[in] NK lengths of K dimension of local matrix [M]
+!> @param[in] LA 1. diagonal of the system matrix [M]
+!> @param[in] LB 2. diagonal of the system matrix [M]
+!> @param[in] LC 3. diagonal of the system matrix [M]
+!> @param[in] LD 4. diagonal of the system matrix [M]
+!> @param[in] LE 5. diagonal of the system matrix [M]
+!> @param[in] LF 6. diagonal of the system matrix [M]
+!> @param[in] LG 7. diagonal of the system matrix [M]
+!> @param[out] LUD helper diagonal elements for preconditioning, vector [UD]
+ SUBROUTINE prepare_ilu(ni,nj,nk,la,lb,lc,ld,le,lf,lg,lud)
+ use mod_linfos
+ IMPLICIT NONE
+ INTEGER ni, nj, nk
+ INTEGER i, j, k
+ DOUBLE PRECISION la(ni,nj,nk), lb(ni,nj,nk), lc(ni,nj,nk)
+ DOUBLE PRECISION ld(ni,nj,nk), le(ni,nj,nk), lf(ni,nj,nk)
+ DOUBLE PRECISION lg(ni,nj,nk)
+ DOUBLE PRECISION lud(ni,nj,nk), tmp, tmp_ud, tmp_d, tmp_bug
+ INTEGER tnul, tnul_
+ LOGICAL test_null, lintel_dummy
+ EXTERNAL test_null
+
+
+ tmp_bug = 0.D0
+!$OMP master
+ CALL dcopy(ni*nj*nk,ld,1,lud,1)
+
+ DO k = 1, nk
+ DO j = 1, nj
+ DO i = 1, ni
+ tmp_ud = lud(i,j,k)
+ tnul = 0
+ CALL test_zero(tmp_ud,1,tnul)
+ tmp_d = ld(i,j,k)
+ tnul_ = 0
+ CALL test_zero(tmp_d,1,tnul_)
+
+ IF ((tnul_/=1) .AND. (tnul/=1)) THEN
+ tmp = 1.0D0/tmp_ud
+
+ IF (i<ni) THEN
+!buggy lUD(i+1,j,k) = lUD(i+1,j,k) -lC(i+1,j,k)*tmp*lE(i,j,k)
+ tmp_bug = lc(i+1,j,k)*tmp
+ lud(i+1,j,k) = lud(i+1,j,k) - tmp_bug*le(i,j,k)
+ END IF
+ IF (j<nj) THEN
+!buggy lUD(i,j+1,k) = lUD(i,j+1,k) -lB(i,j+1,k)*tmp*lF(i,j,k)
+ tmp_bug = lb(i,j+1,k)*tmp
+ lud(i,j+1,k) = lud(i,j+1,k) - tmp_bug*lf(i,j,k)
+ END IF
+ IF (k<nk) THEN
+!buggy lUD(i,j,k+1) = lUD(i,j,k+1) -lA(i,j,k+1)*tmp*lG(i,j,k)
+ tmp_bug = la(i,j,k+1)*tmp
+ lud(i,j,k+1) = lud(i,j,k+1) - tmp_bug*lg(i,j,k)
+ END IF
+ ELSE
+ WRITE(*,'(A,3I5,A,2e15.8)') &
+ 'error in prepare_solve.f90: main diagonal element equal to zero at ', i, &
+ j, k, '=', ld(i,j,k), lud(i,j,k)
+ STOP
+ END IF
+ END DO
+ END DO
+ END DO
+!$OMP end master
+!$OMP barrier
+
+! break intel-compiler optimisation,
+! to avoid numerical instabilities for
+! lUD(i+1,j,k) = lUD(i+1,j,k) - [ lC(i+1,j,k)*tmp ] *lE(i,j,k)
+! lUD(i,j+1,k) = lUD(i,j+1,k) - [ lB(i,j+1,k)*tmp ] *lF(i,j,k)
+! lUD(i,j,k+1) = lUD(i,j,k+1) - [ lA(i,j,k+1)*tmp ] *lG(i,j,k)
+ lintel_dummy = test_null(tmp_bug)
+
+! faster ...
+!$OMP do schedule(static)
+ DO k = 1, nk
+ DO j = 1, nj
+ DO i = 1, ni
+! for UD, an near NULL criteria is saver
+ tmp_ud = lud(i,j,k)
+ tnul = 0
+ CALL test_zero(tmp_ud,1,tnul)
+ IF ((ld(i,j,k)/=0.0D0) .AND. (tnul/=1)) THEN
+ lud(i,j,k) = 1.0D0/tmp_ud
+ END IF
+ END DO
+ END DO
+ END DO
+!$OMP end do nowait
+
+ RETURN
+ END
+
+!> @brief copy "private", distribute the "shared" [full] vector into the [local] "private" block area
+!> @param[in] NI lengths of I dimension of local matrix [M]
+!> @param[in] NJ lengths of J dimension of local matrix [M]
+!> @param[in] NK lengths of K dimension of local matrix [M]
+!> @param[in] full global "shared" vector [full]
+!> @param[out] local "private" block vector [local]
+!> @param[in] lxyz_block number of blocks
+!> @param[in] xyz_block block dimensions
+ SUBROUTINE lcopy_ilu(ni,nj,nk,full,local,lxyz_block,xyz_block)
+! use mod_genrl
+ use mod_blocking_size
+ IMPLICIT NONE
+ integer :: i, j, k
+ INTEGER ni,nj,nk,i1, j1, k1, i2, j2, k2, i_max, j_max, k_max, ii
+ DOUBLE PRECISION full(ni,nj,nk)
+ DOUBLE PRECISION local(block_i,block_j,block_k,*)
+ INTEGER lxyz_block, xyz_block(3,lxyz_block)
+
+! search all blocks - identify private
+ DO ii = 1, lxyz_block
+ i = xyz_block(1,ii)
+ j = xyz_block(2,ii)
+ k = xyz_block(3,ii)
+! global block offset (-1)
+ i2 = block_i*(i-1)
+ j2 = block_j*(j-1)
+ k2 = block_k*(k-1)
+! block length
+ k_max = min(block_k,nk-k2)
+ j_max = min(block_j,nj-j2)
+ i_max = min(block_i,ni-i2)
+! clear all (dummy-)values
+ DO k1 = k_max + 1, block_k
+ DO j1 = 1, block_j
+ DO i1 = 1, block_i
+! | + + | | * + |
+! | # # | | # # |
+ local(i1,j1,k1,ii) = 0.0D0
+ END DO
+ END DO
+ END DO
+ DO k1 = 1, k_max
+ DO j1 = j_max + 1, block_j
+ DO i1 = 1, block_i
+! | + # | | * # |
+! | # # | | # # |
+ local(i1,j1,k1,ii) = 0.0D0
+ END DO
+ END DO
+ END DO
+ DO k1 = 1, k_max
+ DO j1 = 1, j_max
+ DO i1 = i_max + 1, block_i
+! | # # | | * # |
+! | # # | | # # |
+ local(i1,j1,k1,ii) = 0.0D0
+ END DO
+ END DO
+ END DO
+! copy private blocks in "local"
+ DO k1 = 1, k_max
+ DO j1 = 1, j_max
+ DO i1 = 1, i_max
+ local(i1,j1,k1,ii) = full(i2+i1,j2+j1,k2+k1)
+ END DO
+ END DO
+ END DO
+ END DO
+!
+ RETURN
+ END
+
+!> @brief copy "shared", collect the [local] "private" blocks into the "shared" [full] vector
+!> @param[in] NI lengths of I dimension of local matrix [M]
+!> @param[in] NJ lengths of J dimension of local matrix [M]
+!> @param[in] NK lengths of K dimension of local matrix [M]
+!> @param[out] full global "shared" vector [full]
+!> @param[in] local "private" block vector [local]
+!> @param[in] lxyz_block number of blocks
+!> @param[in] xyz_block block dimensions
+ SUBROUTINE lcopy_bak_ilu(ni,nj,nk,full,local,lxyz_block,xyz_block)
+! use mod_genrl
+ use mod_blocking_size
+ IMPLICIT NONE
+ integer :: i, j, k
+ INTEGER ni,nj,nk,i1, j1, k1, i2, j2, k2, i_max, j_max, k_max, ii
+ DOUBLE PRECISION full(ni,nj,nk)
+ DOUBLE PRECISION local(block_i,block_j,block_k,*)
+ INTEGER lxyz_block, xyz_block(3,lxyz_block)
+
+! search all blocks - identify private
+ DO ii = 1, lxyz_block
+ i = xyz_block(1,ii)
+ j = xyz_block(2,ii)
+ k = xyz_block(3,ii)
+! global block offset (-1)
+ i2 = block_i*(i-1)
+ j2 = block_j*(j-1)
+ k2 = block_k*(k-1)
+! block length
+ k_max = min(block_k,nk-k2)
+ j_max = min(block_j,nj-j2)
+ i_max = min(block_i,ni-i2)
+! copy bak private blocks in "full"
+ DO k1 = 1, k_max
+ DO j1 = 1, j_max
+ DO i1 = 1, i_max
+ full(i2+i1,j2+j1,k2+k1) = local(i1,j1,k1,ii)
+ END DO
+ END DO
+ END DO
+ END DO
+!$OMP barrier
+!
+ RETURN
+ END
+
+!> @brief copy surface/boundary (position-1) - make private
+!> @param[in] NI lengths of I dimension of local matrix [M]
+!> @param[in] NJ lengths of J dimension of local matrix [M]
+!> @param[in] NK lengths of K dimension of local matrix [M]
+!> @param[in] ii block index number
+!> @param[in] full global "shared" vector
+!> @param[out] local "private" boundary buffer
+!> @param[in] lxyz_block number of blocks
+!> @param[in] xyz_block block dimensions
+ SUBROUTINE lsurf_ilu(ni,nj,nk,ii,full,local,lxyz_block,xyz_block)
+! use mod_genrl
+ use mod_blocking_size
+ IMPLICIT NONE
+ integer :: i, j, k
+ INTEGER lxyz_block, xyz_block(3,lxyz_block)
+ INTEGER ni,nj,nk,i1, j1, k1, i2, j2, k2, i_max, j_max, k_max, ii, offs
+ DOUBLE PRECISION full(ni,nj,nk)
+ DOUBLE PRECISION local(block_i*block_j+block_i*block_k+ &
+ block_j*block_k)
+
+! search all blocks - identify private
+ i = xyz_block(1,ii)
+ j = xyz_block(2,ii)
+ k = xyz_block(3,ii)
+! global block offset (-1)
+ i2 = block_i*(i-1)
+ j2 = block_j*(j-1)
+ k2 = block_k*(k-1)
+! block length
+ i_max = min(block_i,ni-i2)
+ j_max = min(block_j,nj-j2)
+ k_max = min(block_k,nk-k2)
+
+! I-dim
+ offs = 0
+ IF (i2>=1) THEN
+ DO k1 = 1, k_max
+ DO j1 = 1, j_max
+ local(offs+j1+block_j*(k1-1)) = full(i2,j2+j1,k2+k1)
+ END DO
+ END DO
+ ELSE
+ DO k1 = 1, k_max
+ DO j1 = 1, j_max
+ local(offs+j1+block_j*(k1-1)) = 0.0D0
+ END DO
+ END DO
+ END IF
+! J-dim
+ offs = offs + block_j*block_k
+ IF (j2>=1) THEN
+ DO k1 = 1, k_max
+ DO i1 = 1, i_max
+ local(offs+i1+block_i*(k1-1)) = full(i2+i1,j2,k2+k1)
+ END DO
+ END DO
+ ELSE
+ DO k1 = 1, k_max
+ DO i1 = 1, i_max
+ local(offs+i1+block_i*(k1-1)) = 0.0D0
+ END DO
+ END DO
+ END IF
+! K-dim
+ offs = offs + block_i*block_k
+ IF (k2>=1) THEN
+ DO j1 = 1, j_max
+ DO i1 = 1, i_max
+ local(offs+i1+block_i*(j1-1)) = full(i2+i1,j2+j1,k2)
+ END DO
+ END DO
+ ELSE
+ DO j1 = 1, j_max
+ DO i1 = 1, i_max
+ local(offs+i1+block_i*(j1-1)) = 0.0D0
+ END DO
+ END DO
+ END IF
+!
+ RETURN
+ END
diff --git a/solve/qddot.f90 b/solve/qddot.f90
new file mode 100644
index 0000000..3d65e8a
--- /dev/null
+++ b/solve/qddot.f90
@@ -0,0 +1,130 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief quad precision; to accumulate two vectors
+!> @param[in] n vector length
+!> @param[in] dx first vector [dx]
+!> @param[in] incx step size for [dx]
+!> @param[in] dy second vector [dy]
+!> @param[in] incy step size for [dy]
+!> @return dot product of [dx].[dy]
+!> @details
+!> This is a modification for quad precision accumulation !!!\n
+!> qd: quad precision; d: to accumulate\n
+!> - dt = qd(1) +d\n
+!> - qd(2) = qd(2) +(d -(dt -qd(1)))\n
+!> - qd(1) = dt\n
+!>
+!> New: enhanced numeric stability with an overlap driven by "wrong"\n
+!>
+!> forms the dot product of two vectors.\n
+!> uses unrolled loops for increments equal to one.\n
+!> jack dongarra, linpack, 3/11/78.\n
+!> modified 12/3/93, array(1) declarations changed to array(*)\n
+ DOUBLE PRECISION FUNCTION qddot(n,dx,incx,dy,incy)
+ DOUBLE PRECISION dx(n), dy(n), d, dquad(2)
+ DOUBLE PRECISION dtemp
+ DOUBLE PRECISION da(4), dquada(4,2)
+ DOUBLE PRECISION dtempa(4)
+ DOUBLE PRECISION, PARAMETER :: wrong=1.00000000000001d0
+ INTEGER i, incx, incy, ix, iy, m, mp1, n
+
+ qddot = 0.0D0
+ dquad(1) = 0.0D0
+ dquad(2) = 0.0D0
+
+ IF (n<=0) RETURN
+ IF (incx==1 .AND. incy==1) GO TO 20
+
+! Code for unequal inCrements or equal inCrements
+! not equal to 1
+
+ ix = 1
+ iy = 1
+ IF (incx<0) ix = (-n+1)*incx + 1
+ IF (incy<0) iy = (-n+1)*incy + 1
+ DO i = 1, n
+ d = dx(ix)*dy(iy)
+ dtemp = (dquad(1) + d)*wrong
+ dquad(2) = dquad(2) + (d-(dtemp-dquad(1)))
+ dquad(1) = dtemp
+ ix = ix + incx
+ iy = iy + incy
+ END DO
+ qddot = dquad(2) + dquad(1)
+ RETURN
+
+! Code for both inCrements equal to 1
+
+! Clean-up loop
+
+20 m = mod(n,4)
+ DO i = 1, 4
+ dquada(i,1) = 0.0D0
+ dquada(i,2) = 0.0D0
+ END DO
+
+ IF (m==0) GO TO 40
+ DO i = 1, m
+ d = dx(i)*dy(i)
+ dtemp = (dquad(1) + d)*wrong
+ dquad(2) = dquad(2) + (d-(dtemp-dquad(1)))
+ dquad(1) = dtemp
+ END DO
+ IF (n<4) GO TO 60
+40 mp1 = m + 1
+
+ DO i = mp1, n, 4
+ da(1) = dx(i)*dy(i)
+ da(2) = dx(i+1)*dy(i+1)
+ da(3) = dx(i+2)*dy(i+2)
+ da(4) = dx(i+3)*dy(i+3)
+ dtempa(1) = (dquada(1,1) + da(1))*wrong
+ dtempa(2) = (dquada(2,1) + da(2))*wrong
+ dtempa(3) = (dquada(3,1) + da(3))*wrong
+ dtempa(4) = (dquada(4,1) + da(4))*wrong
+ dquada(1,2) = dquada(1,2) + (da(1)-(dtempa(1)-dquada(1,1)))
+ dquada(2,2) = dquada(2,2) + (da(2)-(dtempa(2)-dquada(2,1)))
+ dquada(3,2) = dquada(3,2) + (da(3)-(dtempa(3)-dquada(3,1)))
+ dquada(4,2) = dquada(4,2) + (da(4)-(dtempa(4)-dquada(4,1)))
+ dquada(1,1) = dtempa(1)
+ dquada(2,1) = dtempa(2)
+ dquada(3,1) = dtempa(3)
+ dquada(4,1) = dtempa(4)
+ END DO
+60 CONTINUE
+ DO i = 1, 4
+ d = dquada(i,2)
+ dtemp = (dquad(1) + d)*wrong
+ dquad(2) = dquad(2) + (d-(dtemp-dquad(1)))
+ dquad(1) = dtemp
+ END DO
+ DO i = 1, 4
+ d = dquada(i,1)
+ dtemp = (dquad(1) + d)*wrong
+ dquad(2) = dquad(2) + (d-(dtemp-dquad(1)))
+ dquad(1) = dtemp
+ END DO
+ qddot = dquad(2) + dquad(1)
+
+ RETURN
+ END
diff --git a/solve/reduction.f90 b/solve/reduction.f90
new file mode 100644
index 0000000..fa78799
--- /dev/null
+++ b/solve/reduction.f90
@@ -0,0 +1,87 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief OpenMP reduction (sum) routine, (enhanced precision)
+!> @param[in] s_private "private" values from each thread
+!> @param[out] sh_help temporary "shared" helper array
+!> @param[in] m vector size (number of reductions)
+!> @param[out] S result, global sum (OpenMP private)
+!> @details
+!> New: enhanced numeric stability with an overlap driven by "wrong"\n
+!>
+!> build the sum (reduction) from s_private to S, where S are overwritten\n
+!> and not used to compute the sum\n
+ SUBROUTINE xsum_0(m,s_private,s,sh_help)
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+! precision staff
+ DOUBLE PRECISION dquad(2)
+ DOUBLE PRECISION, PARAMETER :: wrong=1.00000000000001d0
+! number of threads
+ INTEGER t, tt
+! loop variables
+ INTEGER i, k, l, m
+! sh_help(#thread * m) : shared array to compute temp. values
+ DOUBLE PRECISION s(m), s_private(m), sh_help(*)
+
+!
+ t = omp_get_num_of_threads()
+ tt = omp_get_his_thread_num() + 1
+! store values of all "m" reductions
+ sh_help(tt) = s_private(1)
+ DO l = 2, m
+ sh_help(tt+(l-1)*t) = s_private(l)
+ END DO
+!$OMP barrier
+!
+!$OMP do schedule(static)
+ DO l = 1, m
+! i: offset for each reduction
+ i = (l-1)*t
+!org s_private(l) = sh_help(1+i)
+!org DO k = 2, t
+!org s_private(l) = s_private(l) + sh_help(k+i)
+!org END DO
+!org sh_help(1+i) = s_private(l)
+!
+! enhanced precision
+ dquad(1) = sh_help(1+i)
+ dquad(2) = 0.0D0
+ DO k = 2, t
+ s_private(l) = (dquad(1) + sh_help(k+i))*wrong
+ dquad(2) = dquad(2) + (sh_help(k+i)-(s_private(l)-dquad(1)))
+ dquad(1) = s_private(l)
+ END DO
+ sh_help(1+i) = dquad(2) + dquad(1)
+ END DO
+!$OMP end do nowait
+!$OMP barrier
+!
+! copy private
+ DO l = 1, m
+ i = (l-1)*t
+ s(l) = sh_help(1+i)
+ END DO
+!
+ RETURN
+ END
diff --git a/solve/set_dval.f90 b/solve/set_dval.f90
new file mode 100644
index 0000000..b2310bc
--- /dev/null
+++ b/solve/set_dval.f90
@@ -0,0 +1,60 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief initialise a double precision vector
+!> @param[in] N length of [x]-vectors
+!> @param[in] alpha value for initialisation
+!> @param[out] x initialised vector [x]
+ SUBROUTINE set_dval(n,alpha,x)
+ IMPLICIT NONE
+! N : length of [x]-vector
+! i : loop variable
+ integer :: n, i
+! vector [x]
+ double precision, dimension (n) :: x
+ double precision :: alpha
+
+ DO i = 1, n
+ x(i) = alpha
+ END DO
+ RETURN
+ END
+
+!> @brief initialise a double precision vector, (OpenMP version)
+!> @param[in] N length of [x]-vectors
+!> @param[in] alpha value for initialisation
+!> @param[out] x initialised vector [x]
+ SUBROUTINE omp_set_dval(n,alpha,x)
+ IMPLICIT NONE
+! N : length of [x]-vector
+! i : loop variable
+ integer :: n, i, tpos, tanz
+! vector [x]
+ double precision, dimension (n) :: x
+ double precision :: alpha
+
+ CALL omp_part(n,tpos,tanz)
+ DO i = tpos, tpos + tanz - 1
+ x(i) = alpha
+ END DO
+ RETURN
+ END
diff --git a/solve/set_ival.f90 b/solve/set_ival.f90
new file mode 100644
index 0000000..ca6205e
--- /dev/null
+++ b/solve/set_ival.f90
@@ -0,0 +1,60 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief initialise an integer vector
+!> @param[in] N length of [x]-vectors
+!> @param[in] alpha value for initialisation
+!> @param[out] x initialised vector [x]
+ SUBROUTINE set_ival(n,alpha,x)
+ IMPLICIT NONE
+! N : length of [x]-vector
+! i : loop variable
+ integer :: n, i
+! vector [x]
+ integer, dimension (n) :: x
+ integer :: alpha
+
+ DO i = 1, n
+ x(i) = alpha
+ END DO
+ RETURN
+ END
+
+!> @brief initialise an integer vector, (OpenMP version)
+!> @param[in] N length of [x]-vectors
+!> @param[in] alpha value for initialisation
+!> @param[out] x initialised vector [x]
+ SUBROUTINE omp_set_ival(n,alpha,x)
+ IMPLICIT NONE
+! N : length of [x]-vector
+! i : loop variable
+ integer :: n, i, tpos, tanz
+! vector [x]
+ integer, dimension (n) :: x
+ integer :: alpha
+
+ CALL omp_part(n,tpos,tanz)
+ DO i = tpos, tpos + tanz - 1
+ x(i) = alpha
+ END DO
+ RETURN
+ END
diff --git a/solve/set_lval.f90 b/solve/set_lval.f90
new file mode 100644
index 0000000..436a2a4
--- /dev/null
+++ b/solve/set_lval.f90
@@ -0,0 +1,60 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief initialise a logical vector
+!> @param[in] N length of [x]-vectors
+!> @param[in] alpha value for initialisation
+!> @param[out] x initialised vector [x]
+ SUBROUTINE set_lval(n,alpha,x)
+ IMPLICIT NONE
+! N : length of [x]-vector
+ INTEGER n
+! vector [x]
+ LOGICAL x(n), alpha
+! i : loop variable
+ INTEGER i
+
+ DO i = 1, n
+ x(i) = alpha
+ END DO
+ RETURN
+ END
+
+!> @brief initialise a logical vector, (OpenMP version)
+!> @param[in] N length of [x]-vectors
+!> @param[in] alpha value for initialisation
+!> @param[out] x initialised vector [x]
+ SUBROUTINE omp_set_lval(n,alpha,x)
+ IMPLICIT NONE
+! N : length of [x]-vector
+ INTEGER n
+! vector [x]
+ LOGICAL x(n), alpha
+! i : loop variable
+ INTEGER i, tpos, tanz
+
+ CALL omp_part(n,tpos,tanz)
+ DO i = tpos, tpos + tanz - 1
+ x(i) = alpha
+ END DO
+ RETURN
+ END
diff --git a/solve/solve.f90 b/solve/solve.f90
new file mode 100644
index 0000000..9ea1c15
--- /dev/null
+++ b/solve/solve.f90
@@ -0,0 +1,181 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief main routine to solve a linear equation system, calls "solve_type" (wrapper)
+!> @param[in] icode specify the physical value
+!> @param[in] species transport species index
+!> @param[in,out] x_solution solution vector of the solved linear system, may be also the start input
+!> @param[in] errorc error
+!> @param[in] apar setup explicit or implicit solver (disabled), default 1.0
+!> @param[in] ctrl solver code
+!> @param[in] ismpl local sample index
+!> @details
+!> solve system equations by preconditioned krylov solvers (bicgstab) or SIP (NAG) and others\n
+ SUBROUTINE solve(icode,species,x_solution,errorc,apar,ctrl,ismpl)
+ use arrays
+ use mod_genrl
+ use mod_flow
+ use mod_temp
+ use mod_conc
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ double precision :: apar, errorc
+ ! double precision :: dnormalise
+ integer :: icode
+ ! integer :: itst
+ integer :: mxit
+ integer :: species
+ integer :: mfactor
+ integer :: ctrl, criteria, precondition, solvername
+ double precision :: x_solution(i0*j0*k0)
+! only for tests with 'abbruch'
+ double precision :: moderrorc
+ ! double precision :: enough
+#ifdef BENCH
+ double precision :: trun
+ double precision :: tend
+#endif
+ intrinsic dsqrt, dble, abs
+
+! -------------
+ moderrorc = errorc
+ IF (ctrl<0) THEN
+ WRITE(*,*) &
+ 'error: old solver compatibility no longer supported'
+ STOP
+ END IF
+
+! **************************************************************************
+! solvername =
+! *0 : BiCGStab [:parallel]
+! 1 : not supported, formerly: NAG [:serial]
+! 2 : CG [:parallel] ( prove symmetry, if not then BiCGStab )
+! 3 : PLU [:serial] (LAPACK) and math tests (stability)
+! (4-7 : not in use !)
+! criteria = < switch to set when should break >
+! 0 : relative stopping crit. : ||[res]|| < depsilon*||[res0]||
+! 1 : absolute stopping crit. : ||[res]|| < depsilon
+! 2 : maximum stopping crit. : max(abs([res])) < depsilon
+! 3 : abs. and rel. stopping crit. : ( ||[res]|| < depsilon ) and ( ||[res]|| < 0.99d0*||[res0]|| )
+! 0.99d0 is a constant for testing only, it is named 'minRel' in 'abbruch.f'
+! *4 : like '3', but with auto detected range for depsilon, default depsilon used when detection fails
+! (5-7 : not in use !)
+! precondition =
+! *0 : ILU [:parallel]
+! 1 : SSOR [:serial]
+! 2 : Diagonal [:parallel]
+! 3 : None [:]
+! (4-7 : not in use !)
+! * : recommended (ctrl = 64)
+! and (ctrl = 67) : for testing
+!
+! [ ctrl = solvername + 16*criteria + 256*precondition ]
+! extract [ ctrl ] :
+! solvername = mod(ctrl,16)
+! ctrl = ctrl/16
+! criteria = mod(ctrl,16)
+! ctrl = ctrl/16
+! precondition = ctrl
+!
+ CALL decntrl3(ctrl,solvername,criteria,precondition)
+
+! **************************************************************************
+
+! -------------
+! defualt multiply factoor
+ mfactor = 1
+!
+ IF (abs(icode)==pv_pres) THEN
+ mxit = lmaxitf
+ IF (criteria>=4) THEN
+ criteria = 1
+ moderrorc = nltolf*1.0D-2
+ END IF
+ END IF
+
+ IF (abs(icode)==pv_conc) THEN
+ mxit = lmaxitc
+ IF (criteria>=4) THEN
+ criteria = 1
+ moderrorc = nltolc*1.0D-2
+ END IF
+ END IF
+
+ IF (abs(icode)==pv_temp) THEN
+ mxit = lmaxitt
+ IF (criteria>=4) THEN
+ criteria = 1
+ moderrorc = nltolt*1.0D-2
+ END IF
+ END IF
+
+ IF (abs(icode)==pv_head) THEN
+ mxit = lmaxitf
+ IF (criteria>=4) THEN
+ criteria = 1
+ moderrorc = nltolf*1.0D-2
+ END IF
+ END IF
+
+! -------------
+
+! -------------
+ IF (tec_out) THEN
+! save current state of the right side vector - may be modified after "solve_type"
+ CALL dcopy(i0*j0*k0,w(1,1,1,ismpl),1,lss_tmp(1,ismpl),1)
+ END IF
+
+! ##################################################################
+! # solver #
+! ##################################################################
+
+#ifdef BENCH
+ CALL sys_cputime(trun)
+#endif
+ CALL solve_type(i0,j0,k0*mfactor,x_solution,w(1,1,1,ismpl),moderrorc, &
+ bc_mask(1,ismpl),solvername,precondition,mxit,criteria, &
+ a(1,1,1,ismpl),b(1,1,1,ismpl),c(1,1,1,ismpl),d(1,1,1,ismpl), &
+ e(1,1,1,ismpl),f(1,1,1,ismpl),g(1,1,1,ismpl),r,apar, &
+ ud(1,1,1,ismpl),ismpl)
+#ifdef BENCH
+ CALL sys_cputime(tend)
+ WRITE(*,*) ' linear system solver time:', tend - trun, 'sec'
+#endif
+
+! ##################################################################
+
+! -------------
+! "icode" < 0 indicates a default input/output in the [x] vector
+ IF (icode<0) THEN
+ CALL dcopy(i0*j0*k0,x_solution,1,x(1,1,1,ismpl),1)
+ END IF
+
+! -------------
+ IF (tec_out) THEN
+! restore the state of the right side vector
+ CALL dcopy(i0*j0*k0,lss_tmp(1,ismpl),1,w(1,1,1,ismpl),1)
+ END IF
+
+
+ RETURN
+ END
diff --git a/solve/solve_debug.f90 b/solve/solve_debug.f90
new file mode 100644
index 0000000..8ff0046
--- /dev/null
+++ b/solve/solve_debug.f90
@@ -0,0 +1,124 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief output routine to debug "solve.f90" input, use this instead of "call solve(...)"
+!> @param[in] csf suffix for the output file name
+!> @param[in] x_cur current solution vector [x]
+!> @param[in] ismpl local sample index
+ SUBROUTINE solve_debug(csf,x_cur,ismpl)
+ use arrays
+ use mod_genrl
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k, l
+! residuum
+ DOUBLE PRECISION, ALLOCATABLE :: dresid(:)
+! max. normalisation value
+ DOUBLE PRECISION, ALLOCATABLE :: dmaxnrm(:)
+ DOUBLE PRECISION x_cur(i0,j0,k0,1)
+ ! DOUBLE PRECISION dvor
+ ! CHARACTER cnach
+ character (len=*) :: csf
+ LOGICAL test_null
+ EXTERNAL test_null
+ INTRINSIC max, abs
+
+! compute "residuum"
+ ALLOCATE(dresid(i0*j0*k0))
+ ALLOCATE(dmaxnrm(i0*j0*k0))
+ CALL s_mvp(i0,j0,k0,x_cur(1,1,1,ismpl),dresid,a(1,1,1,ismpl), &
+ b(1,1,1,ismpl),c(1,1,1,ismpl),d(1,1,1,ismpl),e(1,1,1,ismpl), &
+ f(1,1,1,ismpl),g(1,1,1,ismpl))
+ CALL daxpy(i0*j0*k0,-1.D0,w(1,1,1,ismpl),1,dresid,1)
+
+ l = 0
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ l = l + 1
+! dmaxnrm(l) = abs(w(i,j,k,ismpl))
+!debug cnach = 'w'
+!debug dvor = dmaxnrm(l)
+! if (K0.gt.1.and.k.gt.1) dmaxnrm(l) = max(dmaxnrm(l),
+! & abs(a(i,j,k,ismpl) *x_Cur(i,j,k-1,ismpl)))
+!debug if (dvor.ne.dmaxnrm(l) ) cnach = 'a'
+!debug dvor = dmaxnrm(l)
+! if (J0.gt.1.and.j.gt.1) dmaxnrm(l) = max(dmaxnrm(l),
+! & abs(b(i,j,k,ismpl) *x_Cur(i,j-1,k,ismpl)))
+!debug if (dvor.ne.dmaxnrm(l) ) cnach = 'b'
+!debug dvor = dmaxnrm(l)
+! if (I0.gt.1.and.i.gt.1) dmaxnrm(l) = max(dmaxnrm(l),
+! & abs(C(i,j,k,ismpl) *x_Cur(i-1,j,k,ismpl)))
+!debug if (dvor.ne.dmaxnrm(l) ) cnach = 'c'
+!debug dvor = dmaxnrm(l)
+! dmaxnrm(l) = max(dmaxnrm(l),
+! & abs(d(i,j,k,ismpl) *x_Cur(i,j,k,ismpl)))
+!debug if (dvor.ne.dmaxnrm(l) ) cnach = 'd'
+!debug dvor = dmaxnrm(l)
+! if (I0.gt.1.and.i.lt.I0) dmaxnrm(l) = max(dmaxnrm(l),
+! & abs(e(i,j,k,ismpl) *x_Cur(i+1,j,k,ismpl)))
+!debug if (dvor.ne.dmaxnrm(l) ) cnach = 'e'
+!debug dvor = dmaxnrm(l)
+! if (J0.gt.1.and.j.lt.J0) dmaxnrm(l) = max(dmaxnrm(l),
+! & abs(f(i,j,k,ismpl) *x_Cur(i,j+1,k,ismpl)))
+!debug if (dvor.ne.dmaxnrm(l) ) cnach = 'f'
+!debug dvor = dmaxnrm(l)
+! if (K0.gt.1.and.k.lt.K0) dmaxnrm(l) = max(dmaxnrm(l),
+! & abs(g(i,j,k,ismpl) *x_Cur(i,j,k+1,ismpl)))
+!debug if (dvor.ne.dmaxnrm(l) ) cnach = 'g'
+!debug if (cnach.ne.'d'.and.cnach.ne.'w')
+!debug & write(*,*) ' ['//cnach//']',l
+ IF (bc_mask(l,ismpl)=='+') THEN
+! diagonal dominance
+ dmaxnrm(l) = abs(d(i,j,k,ismpl))
+ IF ( .NOT. test_null(x_cur(i,j,k, &
+ ismpl))) dmaxnrm(l) = abs(d(i,j,k,ismpl)* &
+ x_cur(i,j,k,ismpl))
+ ELSE
+ dmaxnrm(l) = 1.D0
+ END IF
+ END DO
+ END DO
+ END DO
+
+ OPEN(999,file='system_'//csf//'.dat',status='REPLACE')
+ WRITE(999,*) '% w x res err base | a b c d e f g'
+ l = 0
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ l = l + 1
+ WRITE(999,'(5d20.8,2A,7d20.8)') w(i,j,k,ismpl), &
+ x_cur(i,j,k,ismpl), dresid(l), dresid(l)/dmaxnrm(l), &
+ dmaxnrm(l), ' ' // bc_mask(l,ismpl), ' | ', &
+ a(i,j,k,ismpl), b(i,j,k,ismpl), c(i,j,k,ismpl), &
+ d(i,j,k,ismpl), e(i,j,k,ismpl), f(i,j,k,ismpl), &
+ g(i,j,k,ismpl)
+ END DO
+ END DO
+ END DO
+ WRITE(999,*) '% w x res err base | a b c d e f g'
+ CLOSE(999)
+ DEALLOCATE(dmaxnrm)
+ DEALLOCATE(dresid)
+ RETURN
+ END
diff --git a/solve/solve_type.f90 b/solve/solve_type.f90
new file mode 100644
index 0000000..3ddf3b7
--- /dev/null
+++ b/solve/solve_type.f90
@@ -0,0 +1,231 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief wrapper routine to call each kind of linear system solver
+!> @param[in] ni lengths of I dimension of local matrix [M]
+!> @param[in] nj lengths of J dimension of local matrix [M]
+!> @param[in] nk lengths of K dimension of local matrix [M]
+!> @param[in,out] l_x solution vector [x], on start = start vector
+!> @param[in] l_w right side, vector [b]
+!> @param[in] moderrc_ only for tests with 'abbruch'
+!> @param[in] l_bc_mask boundary condition pattern (mask)
+!> @param[in] solvername solver name, code for CG, BiCGStab...
+!> @param[in] precondition preconditioner code for None, Diagonal, SSOR or ILU(0)
+!> @param[in] MXIT max iteration number
+!> @param[in] criteria_ precision criteria mode to break iterations\n
+!> - 0 : relative stopping crit.: ||[res]|| < depsilon*||[res0]||\n
+!> - 1 : absolute stopping crit.: ||[res]|| < depsilon\n
+!> - 2 : maximum stopping crit.: max(abs([res])) < depsilon\n
+!> first [res]^=[r], later (if precise enough): [res]^=([M]x[x]-[b])
+!> @param[in] L_A 1. diagonal of the system matrix [M]
+!> @param[in] L_B 2. diagonal of the system matrix [M]
+!> @param[in] L_C 3. diagonal of the system matrix [M]
+!> @param[in] L_D 4. diagonal of the system matrix [M]
+!> @param[in] L_E 5. diagonal of the system matrix [M]
+!> @param[in] L_F 6. diagonal of the system matrix [M]
+!> @param[in] L_G 7. diagonal of the system matrix [M]
+!> @param[in] l_r random vector [r0_hat] ^= [r0^]
+!> @param[in] APAR explicit - implicit solver switch (default 1.0)
+!> @param[in] L_UD helper diagonal elements for preconditioning
+!> @param[in] ismpl local sample index
+!> @details
+!> Function: wrapper for any solver, spec. by criteria\n
+!> Input/Output: see in 'solver.f90'\n
+ SUBROUTINE solve_type(ni,nj,nk,l_x,l_w,moderrc_,l_bc_mask, &
+ solvername,precondition,mxit,criteria_,l_a,l_b,l_c,l_d,l_e, &
+ l_f,l_g,l_r,apar,l_ud,ismpl)
+ use arrays
+ use mod_linfos
+ use mod_genrl
+ IMPLICIT NONE
+ INTEGER ni, nj, nk
+ DOUBLE PRECISION moderrc_, l_a(ni,nj,nk), l_b(ni,nj,nk), &
+ l_c(ni,nj,nk), l_d(ni,nj,nk), l_e(ni,nj,nk), l_f(ni,nj,nk), &
+ l_g(ni,nj,nk), l_ud(ni,nj,nk)
+ DOUBLE PRECISION apar, l_x(ni,nj,nk), l_w(ni,nj,nk), &
+ l_r(ni,nj,nk)
+ CHARACTER l_bc_mask(ni,nj,nk)
+ INTEGER criteria_, solvername, mxit, ii
+ INTEGER precondition, ismpl
+ LOGICAL test_symmetry, ldummy
+ EXTERNAL test_symmetry
+
+
+! ##################################################################
+! # solver #
+! ##################################################################
+
+! ** nag solver not supported anymore **
+ IF (solvername==1) THEN
+ write(unit = *, fmt = *) '[E] error: nag solver not&
+ & supported anymore.'
+ stop
+ END IF
+
+! ---------------------------------------------------------
+
+! ** use Cg solver **
+ IF (solvername==2) THEN
+! test about symmetry
+ IF (test_symmetry(ismpl)) THEN
+! symmetriC solver ilu-preCo
+ IF (precondition==0) THEN
+ IF (linfos(4)>=2) WRITE(*,*) ' ilu precondition'
+ CALL omp_sym_solve_ilu(ni,nj,nk,l_x,l_w,moderrc_, &
+ l_bc_mask,mxit,criteria_,l_a,l_b,l_c,l_d,l_e,l_f,l_g, &
+ l_ud,lss_bound_block(1,1,1,1,1,ismpl), &
+ lss_dnrm(1,ismpl),lss_lma(1,1,ismpl), &
+ lss_lmb(1,1,ismpl),lss_lmc(1,1,ismpl), &
+ lss_lmd(1,1,ismpl),lss_lme(1,1,ismpl), &
+ lss_lmf(1,1,ismpl),lss_lmg(1,1,ismpl), &
+ lss_lud(1,1,ismpl),lss_lx(1,1,ismpl), &
+ lss_lb(1,1,ismpl),lss_ldnrm(1,1,ismpl), &
+ lss_lloctmp(1,1,1,ismpl),lss_ud_block(1,1,1,ismpl), &
+ ismpl)
+ RETURN
+ END IF
+
+ IF (precondition==1) THEN
+ IF (linfos(4)>=2) WRITE(*,*) ' ssor precondition'
+ CALL omp_sym_solve_ssor(ni,nj,nk,l_x,l_w,moderrc_, &
+ l_bc_mask,mxit,criteria_,l_a,l_b,l_c,l_d,l_e,l_f,l_g, &
+ lss_lloctmp(1,1,1,ismpl),lss_dnrm(1,ismpl),ismpl)
+ RETURN
+ END IF
+
+ IF (precondition==2) THEN
+ IF (linfos(4)>=2) WRITE(*,*) ' diagonal precondition'
+ CALL omp_sym_solve_diag(ni,nj,nk,l_x,l_w,moderrc_, &
+ l_bc_mask,mxit,criteria_,l_a,l_b,l_c,l_d,l_e,l_f,l_g, &
+ lss_lloctmp(1,1,1,ismpl),lss_dnrm(1,ismpl),ismpl)
+ RETURN
+ END IF
+
+ IF (precondition==3) THEN
+ IF (linfos(4)>=2) WRITE(*,*) ' no precondition'
+ CALL omp_sym_solve(ni,nj,nk,l_x,l_w,moderrc_,l_bc_mask, &
+ mxit,criteria_,l_a,l_b,l_c,l_d,l_e,l_f,l_g, &
+ lss_lloctmp(1,1,1,ismpl),lss_dnrm(1,ismpl),ismpl)
+ RETURN
+ END IF
+ ELSE
+ solvername = 0
+ END IF
+ END IF
+
+! ---------------------------------------------------------
+
+! ** use biCgstab solver **
+ IF (solvername==0) THEN
+! generic solver ilu-preco
+ IF (precondition==0) THEN
+ IF (linfos(4)>=2) WRITE(*,*) ' ilu precondition'
+ CALL omp_gen_solve_ilu(ni,nj,nk,l_x,l_w,l_r,moderrc_, &
+ l_bc_mask,mxit,criteria_,l_a,l_b,l_c,l_d,l_e,l_f,l_g, &
+ l_ud,lss_bound_block(1,1,1,1,1,ismpl),lss_dnrm(1,ismpl), &
+ lss_lma(1,1,ismpl),lss_lmb(1,1,ismpl), &
+ lss_lmc(1,1,ismpl),lss_lmd(1,1,ismpl), &
+ lss_lme(1,1,ismpl),lss_lmf(1,1,ismpl), &
+ lss_lmg(1,1,ismpl),lss_lud(1,1,ismpl),lss_lx(1,1,ismpl), &
+ lss_lb(1,1,ismpl),lss_lr0_hat(1,1,ismpl), &
+ lss_ldnrm(1,1,ismpl),lss_lloctmp(1,1,1,ismpl), &
+ lss_ud_block(1,1,1,ismpl),ismpl)
+ RETURN
+ END IF
+
+ IF (precondition==1) THEN
+ IF (linfos(4)>=2) WRITE(*,*) ' ssor precondition'
+ CALL omp_gen_solve_ssor(ni,nj,nk,l_x,l_w,l_r,moderrc_, &
+ l_bc_mask,mxit,criteria_,l_a,l_b,l_c,l_d,l_e,l_f,l_g, &
+ lss_lloctmp(1,1,1,ismpl),lss_dnrm(1,ismpl),ismpl)
+ RETURN
+ END IF
+
+ IF (precondition==2) THEN
+ IF (linfos(4)>=2) WRITE(*,*) ' diagonal precondition'
+ CALL omp_gen_solve_diag(ni,nj,nk,l_x,l_w,l_r,moderrc_, &
+ l_bc_mask,mxit,criteria_,l_a,l_b,l_c,l_d,l_e,l_f,l_g, &
+ lss_lloctmp(1,1,1,ismpl),lss_dnrm(1,ismpl),ismpl)
+ RETURN
+ END IF
+
+ IF (precondition==3) THEN
+ IF (linfos(4)>=2) WRITE(*,*) ' no precondition'
+ CALL omp_gen_solve(ni,nj,nk,l_x,l_w,l_r,moderrc_, &
+ l_bc_mask,mxit,criteria_,l_a,l_b,l_c,l_d,l_e,l_f,l_g, &
+ lss_lloctmp(1,1,1,ismpl),lss_dnrm(1,ismpl),ismpl)
+ RETURN
+ END IF
+ END IF
+
+! ---------------------------------------------------------
+
+! ** use PLU (LAPACK) and make math tests **
+ IF (solvername==3) THEN
+! --------------------------------
+! test about symmetry and stability
+ ldummy = test_symmetry(ismpl)
+
+ CALL test_matrix(ismpl)
+! --------------------------------
+! memory space enough ?
+ ii = ni*nj
+ IF (ni==1) ii = ni*nj
+ IF (nj==1) ii = ni*nj
+ IF (nk==1) ii = ni
+
+ IF (8.0D0*dble(3*ii+1)*dble(ni*nj*nk)<=2.0D9) THEN
+ CALL direct_solve(ni,nj,nk,l_x,l_w,l_a,l_b,l_c,l_d,l_e, &
+ l_f,l_g)
+ ELSE
+ IF (linfos(4)>=2) WRITE(*,'(A,F12.2,A)') &
+ ' choose BICGStab (PLU need :', &
+ (8.0D0*dble(3*ii+1)*dble(ni*nj*nk)/(1024.0D0*1024.0D0)), &
+ ' MByte, which is more than 2GByte)'
+! BiCGStab with ILU(0) precondition
+ CALL omp_gen_solve_ilu(ni,nj,nk,l_x,l_w,l_r,moderrc_, &
+ l_bc_mask,mxit,criteria_,l_a,l_b,l_c,l_d,l_e,l_f,l_g, &
+ l_ud,lss_bound_block(1,1,1,1,1,ismpl),lss_dnrm(1,ismpl), &
+ lss_lma(1,1,ismpl),lss_lmb(1,1,ismpl), &
+ lss_lmc(1,1,ismpl),lss_lmd(1,1,ismpl), &
+ lss_lme(1,1,ismpl),lss_lmf(1,1,ismpl), &
+ lss_lmg(1,1,ismpl),lss_lud(1,1,ismpl),lss_lx(1,1,ismpl), &
+ lss_lb(1,1,ismpl),lss_lr0_hat(1,1,ismpl), &
+ lss_ldnrm(1,1,ismpl),lss_lloctmp(1,1,1,ismpl), &
+ lss_ud_block(1,1,1,ismpl),ismpl)
+ END IF
+ END IF
+
+! ---------------------------------------------------------
+
+! multi-phase newton bicgstb solver ilu-preco
+ IF (solvername==4) THEN
+ write(unit = *, fmt = *) '[E] error: multi-phase newton solver not'// &
+ 'supported anymore.'
+ stop
+ END IF
+
+
+! ---------------------------------------------------------
+
+ RETURN
+ END
diff --git a/solve/ssor_mvp_single.f90 b/solve/ssor_mvp_single.f90
new file mode 100644
index 0000000..a25435a
--- /dev/null
+++ b/solve/ssor_mvp_single.f90
@@ -0,0 +1,154 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief apply 7point-star matrix multiply [as]:=[M]x[s]
+!> @param[in] N_I lengths of I dimension of local matrix [M]
+!> @param[in] N_J lengths of J dimension of local matrix [M]
+!> @param[in] N_K lengths of K dimension of local matrix [M]
+!> @param[in] s vector [s]
+!> @param[out] as vector [as]
+!> @param[out] t temporary vector, used for computation
+!> @param[in] MA 1. diagonal of the system matrix [M]
+!> @param[in] MB 2. diagonal of the system matrix [M]
+!> @param[in] MC 3. diagonal of the system matrix [M]
+!> @param[in] MD 4. (main) diagonal of the system matrix [M]
+!> @param[in] ME 5. diagonal of the system matrix [M]
+!> @param[in] MF 6. diagonal of the system matrix [M]
+!> @param[in] MG 7. diagonal of the system matrix [M]
+!> @details
+!> OpenMP parallelised, general version - no special blocking\n
+!> apply 7point-star matrix multiply\n
+!> compute [as]:=[M]x[s], [s],[as],[M] given in 3-D-structure\n
+!> Data-Cube :\n
+!> @image html cube.png
+! k * * * *
+! / * * *
+! 0 -j * * * * *
+! | * * *
+! i * * *
+! * * * *
+ SUBROUTINE ssor_mvp_single(n_i,n_j,n_k,s,as,t,ma,mb,mc,md,me,mf, &
+ mg)
+ use mod_OMP_TOOLS
+ IMPLICIT NONE
+ INCLUDE 'OMP_TOOLS.inc'
+ INTEGER n_i, n_j, n_k
+!
+ DOUBLE PRECISION s(n_i,n_j,n_k), as(n_i,n_j,n_k)
+ DOUBLE PRECISION ma(n_i,n_j,n_k), mb(n_i,n_j,n_k), &
+ mc(n_i,n_j,n_k)
+ DOUBLE PRECISION md(n_i,n_j,n_k), me(n_i,n_j,n_k), &
+ mf(n_i,n_j,n_k)
+ DOUBLE PRECISION mg(n_i,n_j,n_k)
+! t : tmp. vector
+ DOUBLE PRECISION t(n_i,n_j,n_k)
+! loop variable
+ INTEGER i, j, k
+!
+ INTEGER panz, ppos
+ EXTERNAL panz, ppos
+! THREAD-stuff
+ ! INTEGER tpos, tanz
+!
+ INTEGER ijk
+
+
+! compute boundary size
+ ijk = n_i*n_j*n_k
+
+
+! #####################################################################
+! Main
+! given : A=L+D+U
+
+! t:=(D+U)^(-1)*s
+
+!$OMP master
+ CALL dcopy(ijk,s,1,t,1)
+
+
+ DO k = n_k, 1, -1
+ DO j = n_j, 1, -1
+ DO i = n_i, 1, -1
+ IF (i<n_i) t(i,j,k) = t(i,j,k) - me(i,j,k)*t(i+1,j,k)
+ IF (j<n_j) t(i,j,k) = t(i,j,k) - mf(i,j,k)*t(i,j+1,k)
+ IF (k<n_k) t(i,j,k) = t(i,j,k) - mg(i,j,k)*t(i,j,k+1)
+!AW ugly hack ...
+ IF (md(i,j,k)/=0.0D0) THEN
+ t(i,j,k) = t(i,j,k)/md(i,j,k)
+ END IF
+ END DO
+ END DO
+ END DO
+
+
+
+!CC t2 : tot, t3 = as
+! t2 =(s - D*t)
+! t3 =(D+L)^(-1) * t2
+
+ CALL dcopy(ijk,s,1,as,1)
+
+!AW call daxpy(ijk,-1.0d0,t,1,as,1)
+ DO k = 1, n_k
+ DO j = 1, n_j
+ DO i = 1, n_i
+ as(i,j,k) = as(i,j,k) - t(i,j,k)*md(i,j,k)
+ END DO
+ END DO
+ END DO
+
+
+ DO k = 1, n_k
+ DO j = 1, n_j
+ DO i = 1, n_i
+ IF (i>1) as(i,j,k) = as(i,j,k) - mc(i,j,k)*as(i-1,j,k)
+ IF (j>1) as(i,j,k) = as(i,j,k) - mb(i,j,k)*as(i,j-1,k)
+ IF (k>1) as(i,j,k) = as(i,j,k) - ma(i,j,k)*as(i,j,k-1)
+!AW ugly hack ...
+ IF (md(i,j,k)/=0.0D0) THEN
+ as(i,j,k) = as(i,j,k)/md(i,j,k)
+ END IF
+ END DO
+ END DO
+ END DO
+
+
+!CC t3 = as, t4 : tot
+! t4 = t + t3
+! A^T*s = D * t4
+
+ CALL daxpy(ijk,1.0D0,t,1,as,1)
+
+ DO k = 1, n_k
+ DO j = 1, n_j
+ DO i = 1, n_i
+ as(i,j,k) = as(i,j,k)*md(i,j,k)
+ END DO
+ END DO
+ END DO
+!$OMP end master
+!$OMP barrier
+
+
+ RETURN
+ END
diff --git a/solve/test_matrix.f90 b/solve/test_matrix.f90
new file mode 100644
index 0000000..bf2f766
--- /dev/null
+++ b/solve/test_matrix.f90
@@ -0,0 +1,152 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief test the numerical stability of the system matrix
+!> @param[in] ismpl local sample index
+ SUBROUTINE test_matrix(ismpl)
+ use arrays
+ use mod_genrl
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+ DOUBLE PRECISION k1, k2, k3, mindiff, max_val
+! to small koeff.
+ PARAMETER (mindiff=1.0D-30)
+ PARAMETER (max_val=1.0D+150)
+ INTEGER fehler, nijk
+ INTRINSIC dabs
+
+ nijk = i0*j0*k0
+! test about math stability
+ fehler = 0
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+! equal matrix lines, but different right sides ?
+ IF (i<i0) THEN
+ k1 = max_val
+ k2 = max_val
+ k3 = max_val
+ IF (d(i,j,k,ismpl)/=0.0D0) k1 = c(i+1,j,k,ismpl)/ &
+ d(i,j,k,ismpl)
+ IF (e(i,j,k,ismpl)/=0.0D0) k2 = d(i+1,j,k,ismpl)/ &
+ e(i,j,k,ismpl)
+ IF (w(i,j,k,ismpl)/=0.0D0) k3 = w(i+1,j,k,ismpl)/ &
+ w(i,j,k,ismpl)
+ IF ((a(i,j,k,ismpl)==0.0D0) .AND. (b(i,j,k, &
+ ismpl)==0.0D0) .AND. (c(i,j,k, &
+ ismpl)==0.0D0) .AND. (0.0D0==a(i+1,j,k, &
+ ismpl)) .AND. (0.0D0==b(i+1,j,k,ismpl)) .AND. & !aw * (d(i,j,k,ismpl).eq.c(i+1,j,k,ismpl)).and.
+!aw * (e(i,j,k,ismpl).eq.d(i+1,j,k,ismpl)).and.
+ (f(i,j,k,ismpl)==0.0D0) .AND. (g(i,j,k, &
+ ismpl)==0.0D0) .AND. (0.0D0==e(i+1,j,k, &
+ ismpl)) .AND. (0.0D0==f(i+1,j,k, &
+ ismpl)) .AND. (0.0D0==g(i+1,j,k,ismpl)) .AND. & !aw * (W(i,j,k,ismpl).ne.W(i+1,j,k,ismpl))
+ ((dabs(k1-k2)<mindiff) .AND. (dabs(k1-k3)> &
+ mindiff))) THEN
+ fehler = fehler + 1
+ WRITE(*,*) ' ', i, j, k, ' i+1'
+ WRITE(*,*) 'D E | W'
+ WRITE(*,*) d(i,j,k,ismpl), e(i,j,k,ismpl), &
+ w(i,j,k,ismpl)
+ WRITE(*,*) 'C D | W'
+ WRITE(*,*) c(i+1,j,k,ismpl), d(i+1,j,k,ismpl), &
+ w(i+1,j,k,ismpl)
+ END IF
+ END IF
+!
+ IF (j<j0) THEN
+ k1 = max_val
+ k2 = max_val
+ k3 = max_val
+ IF (d(i,j,k,ismpl)/=0.0D0) k1 = b(i,j+1,k,ismpl)/ &
+ d(i,j,k,ismpl)
+ IF (f(i,j,k,ismpl)/=0.0D0) k2 = d(i,j+1,k,ismpl)/ &
+ f(i,j,k,ismpl)
+ IF (w(i,j,k,ismpl)/=0.0D0) k3 = w(i,j+1,k,ismpl)/ &
+ w(i,j,k,ismpl)
+ IF ((a(i,j,k,ismpl)==0.0D0) .AND. (b(i,j,k, &
+ ismpl)==0.0D0) .AND. (c(i,j,k, &
+ ismpl)==0.0D0) .AND. (0.0D0==a(i,j+1,k, &
+ ismpl)) .AND. (0.0D0==c(i,j+1,k,ismpl)) .AND. & !aw * (d(i,j,k,ismpl).eq.b(i,j+1,k,ismpl)).and.
+!aw * (f(i,j,k,ismpl).eq.d(i,j+1,k,ismpl)).and.
+ (e(i,j,k,ismpl)==0.0D0) .AND. (g(i,j,k, &
+ ismpl)==0.0D0) .AND. (0.0D0==e(i,j+1,k, &
+ ismpl)) .AND. (0.0D0==f(i,j+1,k, &
+ ismpl)) .AND. (0.0D0==g(i,j+1,k,ismpl)) .AND. & !aw * (W(i,j,k,ismpl).ne.W(i+1,j,k,ismpl))
+ ((dabs(k1-k2)<mindiff) .AND. (dabs(k1-k3)> &
+ mindiff))) THEN
+ fehler = fehler + 1
+ WRITE(*,*) ' ', i, j, k, ' j+1'
+ WRITE(*,*) 'D F | W'
+ WRITE(*,*) d(i,j,k,ismpl), f(i,j,k,ismpl), &
+ w(i,j,k,ismpl)
+ WRITE(*,*) 'B D | W'
+ WRITE(*,*) b(i,j+1,k,ismpl), d(i,j+1,k,ismpl), &
+ w(i,j+1,k,ismpl)
+ END IF
+ END IF
+!
+ IF (k<k0) THEN
+ k1 = max_val
+ k2 = max_val
+ k3 = max_val
+ IF (d(i,j,k,ismpl)/=0.0D0) k1 = a(i,j,k+1,ismpl)/ &
+ d(i,j,k,ismpl)
+ IF (g(i,j,k,ismpl)/=0.0D0) k2 = d(i,j,k+1,ismpl)/ &
+ g(i,j,k,ismpl)
+ IF (w(i,j,k,ismpl)/=0.0D0) k3 = w(i,j,k+1,ismpl)/ &
+ w(i,j,k,ismpl)
+ IF ((a(i,j,k,ismpl)==0.0D0) .AND. (b(i,j,k, &
+ ismpl)==0.0D0) .AND. (c(i,j,k, &
+ ismpl)==0.0D0) .AND. (0.0D0==c(i,j,k+1, &
+ ismpl)) .AND. (0.0D0==b(i,j,k+1,ismpl)) .AND. & !aw * (d(i,j,k,ismpl).eq.a(i,j,k+1,ismpl)).and.
+!aw * (g(i,j,k,ismpl).eq.d(i,j,k+1,ismpl)).and.
+ (f(i,j,k,ismpl)==0.0D0) .AND. (e(i,j,k, &
+ ismpl)==0.0D0) .AND. (0.0D0==e(i,j,k+1, &
+ ismpl)) .AND. (0.0D0==f(i,j,k+1, &
+ ismpl)) .AND. (0.0D0==g(i,j,k+1,ismpl)) .AND. & !aw * (W(i,j,k,ismpl).ne.W(i+1,j,k,ismpl))
+ ((dabs(k1-k2)<mindiff) .AND. (dabs(k1-k3)> &
+ mindiff))) THEN
+ fehler = fehler + 1
+ WRITE(*,*) ' ', i, j, k, ' K+1'
+ WRITE(*,*) 'D G | W'
+ WRITE(*,*) d(i,j,k,ismpl), g(i,j,k,ismpl), &
+ w(i,j,k,ismpl)
+ WRITE(*,*) 'A D | W'
+ WRITE(*,*) a(i,j,k+1,ismpl), d(i,j,k+1,ismpl), &
+ w(i,j,k+1,ismpl)
+ END IF
+ END IF
+ END DO
+ END DO
+ END DO
+ IF (fehler>0) THEN
+ WRITE(*,*) &
+ 'error: inconsistent system, can not be solved ! (', &
+ fehler, &
+ ' linear lines with different right hand sides)'
+ STOP
+ END IF
+!
+ RETURN
+ END
diff --git a/solve/test_symmetry.f90 b/solve/test_symmetry.f90
new file mode 100644
index 0000000..fbdcec0
--- /dev/null
+++ b/solve/test_symmetry.f90
@@ -0,0 +1,72 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief test the symmetry of the system matrix
+!> @param[in] ismpl local sample index
+!> @return true: when the matrix is symmetric
+ LOGICAL FUNCTION test_symmetry(ismpl)
+ use arrays
+ use mod_genrl
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j, k
+! to small koeff.
+ INTEGER fehler
+ LOGICAL isit
+
+! test about symmetry
+ fehler = 0
+ DO k = 1, k0
+ DO j = 1, j0
+ DO i = 1, i0
+ IF (d(i,j,k,ismpl)/=0.0D0) THEN
+ IF (i>1) THEN
+ IF ((c(i,j,k,ismpl)/=e(i-1,j,k,ismpl)) .AND. (d(i-1, &
+ j,k,ismpl)/=0.0D0)) fehler = fehler + 1
+ END IF
+ IF (j>1) THEN
+ IF ((b(i,j,k,ismpl)/=f(i,j-1,k,ismpl)) .AND. (d(i, &
+ j-1,k,ismpl)/=0.0D0)) fehler = fehler + 1
+ END IF
+ IF (k>1) THEN
+ IF ((a(i,j,k,ismpl)/=g(i,j,k-1,ismpl)) .AND. (d(i,j, &
+ k-1,ismpl)/=0.0D0)) fehler = fehler + 1
+ END IF
+ END IF
+ END DO
+ END DO
+ END DO
+!
+ IF (fehler==0) THEN
+ IF (linfos(4)>=2) WRITE(*,*) ' Symmetric matrix !'
+ isit = .TRUE.
+ ELSE
+ IF (linfos(4)>=2) WRITE(*,*) ' Unsymmetric matrix with ', &
+ fehler, ' unsym. points !'
+ isit = .FALSE.
+ END IF
+!
+ test_symmetry = isit
+!
+ RETURN
+ END
diff --git a/solve/test_zero.f90 b/solve/test_zero.f90
new file mode 100644
index 0000000..8d9247a
--- /dev/null
+++ b/solve/test_zero.f90
@@ -0,0 +1,81 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief zero test, is [v]=0 ?
+!> @param[in] v variable to test
+!> @param[in] code break code for debug
+!> @param[out] divide_zero 0: not zero, [code]: if [v] is zero
+!> @param[out] v modified to 1.0d0, if [v] is close to zero on entry
+ SUBROUTINE test_zero(v,code,divide_zero)
+ use arrays
+ IMPLICIT NONE
+! stop if v=0
+ DOUBLE PRECISION v
+ INTEGER code, divide_zero
+ INTRINSIC dabs
+
+! 3/4 of minimum value (not zero)
+ IF (dabs(v)<const_dble(2)) THEN
+ divide_zero = code
+ v = 1.0D0
+ ELSE
+! never change it bak
+!AW divide_zero = 0
+ END IF
+ RETURN
+ END
+
+!> @brief "Not A Number" test, is [v]="NAN" ?
+!> @param[in] v variable to test
+!> @return TRUE: if [v] is close to "NAN"
+ LOGICAL FUNCTION test_nan(v)
+ use arrays
+ IMPLICIT NONE
+! stop if v=NAN
+ DOUBLE PRECISION v
+ INTRINSIC dabs
+
+! 3/4 of maximum value (not infinite)
+ IF (dabs(v)>const_dble(3)) THEN
+ test_nan = .TRUE.
+ ELSE
+ test_nan = .FALSE.
+ END IF
+ RETURN
+ END
+
+!> @brief zero test, is [v]=0 ?
+!> @param[in] v variable to test
+!> @return TRUE: if [v] is close to zero
+ LOGICAL FUNCTION test_null(v)
+ use arrays
+ IMPLICIT NONE
+ DOUBLE PRECISION v
+ INTRINSIC dabs
+
+ IF (dabs(v)<const_dble(2)) THEN
+ test_null = .TRUE.
+ ELSE
+ test_null = .FALSE.
+ END IF
+ RETURN
+ END
diff --git a/user/none/calc_user.f90 b/user/none/calc_user.f90
new file mode 100644
index 0000000..baa8c51
--- /dev/null
+++ b/user/none/calc_user.f90
@@ -0,0 +1,57 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief initialisation routine, no "reinjection" functionality
+!> @param[in] ismpl local sample index
+ SUBROUTINE user_init(ismpl)
+ use arrays
+ use mod_genrl
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i
+
+ IF (linfos(3)>=2) WRITE(*,*) ' ... user_init (REINJECTION)'
+! avoid side effects
+ DO i = 1, nbc_data
+! init from the first set
+ dbc_dataold(i) = dbc_data(i,1,1)
+ END DO
+ RETURN
+ END
+
+!> @brief reinjection "dummy" routine, no "reinjection" functionality
+!> @param[in] ismpl local sample index
+ SUBROUTINE calc_user(ismpl)
+ use arrays
+ use mod_genrl
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i
+ INTRINSIC int
+
+ IF (linfos(3)>=2) WRITE(*,*) ' ... calc_user'
+! Dummy body
+ i = int(head(1,1,1,ismpl))
+ RETURN
+ END
diff --git a/user/none/user_check.f90 b/user/none/user_check.f90
new file mode 100644
index 0000000..9ec7a89
--- /dev/null
+++ b/user/none/user_check.f90
@@ -0,0 +1,50 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief check current user directory choice
+!> @param[in] ismpl local sample index
+ SUBROUTINE user_check(ismpl)
+ use mod_genrlc
+ IMPLICIT NONE
+ integer :: ismpl
+ character (len=20) :: ldef_user
+ PARAMETER (ldef_user='none')
+ logical :: test_option
+ EXTERNAL test_option
+ INTRINSIC trim
+
+#ifndef USER_none
+ WRITE(*,'(3A)') 'error: this source was written for USER=', &
+ ldef_user, ', please correct this check in "user_check.f"!'
+ STOP
+#endif
+ IF ( .NOT. test_option('USER='//trim(def_user))) THEN
+ IF (ldef_user/=def_user) THEN
+ WRITE(*,'(7A)') 'error: model file needs an executable', &
+ ' build from USER=', trim(def_user), &
+ ', but the current', ' consist of USER=', &
+ trim(ldef_user), '!'
+ STOP
+ END IF
+ END IF
+ RETURN
+ END
diff --git a/user/none/write_monitor_user.f90 b/user/none/write_monitor_user.f90
new file mode 100644
index 0000000..1ab1dd8
--- /dev/null
+++ b/user/none/write_monitor_user.f90
@@ -0,0 +1,81 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief writes data in tecplot-format (example routine)
+!> @param[in] otype orientation type:\n
+!> - 1 new file\n
+!> - 2 append\n
+!> @param[in] ismpl local sample index
+ subroutine write_monitor_user(otype,ismpl)
+
+ ! use mod_genrl, only: out_orientation
+ ! use mod_genrlc, only: project
+ ! use mod_time, only: simtime, tunit
+
+ implicit none
+
+ ! otype:
+ ! 1 new file
+ ! 2 append
+ integer, intent (in) :: otype
+
+ ! Samples index
+ integer :: ismpl
+
+ ! logical :: ltimes
+ ! logical :: lmonip
+ ! character (len=256) :: filename
+ ! integer, external :: lblank
+
+
+ ! ! Orientation of monitoring output
+ ! if (out_orientation==2 .or. out_orientation==3) then
+ ! ltimes = .true.
+ ! else
+ ! ltimes = .false.
+ ! end if
+
+ ! if (out_orientation==4) then
+ ! lmonip = .true.
+ ! else
+ ! lmonip = .false.
+ ! end if
+
+ ! ! Output Filename
+ ! call chln(project,i1,i2)
+ ! filename = project(i1:i2)//'_monitor_user.dat'
+
+ ! if (ltimes) then
+ ! write(filename,'(2A,1e14.8,1A)') &
+ ! project(i1:i2),'_', &
+ ! (simtime(ismpl))/tunit,'_monitor_user.dat'
+ ! endif
+
+ ! if (linfos(3).ge.2.and..not.lmonip) then
+ ! write(*,'(3A)') ' [W] : User Monitor points to "', &
+ ! filename(1:lblank(filename)),'"'
+ ! endif
+
+
+ return
+
+ end subroutine write_monitor_user
diff --git a/user/none/write_user.f90 b/user/none/write_user.f90
new file mode 100644
index 0000000..c6a4a0d
--- /dev/null
+++ b/user/none/write_user.f90
@@ -0,0 +1,65 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief special output defined by the developer of this working directory (example routine)
+!> @param[in] ident iteration number
+!> @param[in] ismpl local sample index
+!> @details
+!> This routine can be taken as a starting point for writing
+!> additional user-defined output routines.
+ subroutine write_user(ident,ismpl)
+
+ implicit none
+
+ ! Sample index
+ integer :: ismpl
+
+ ! iteration number
+ integer, intent (in) ::ident
+
+ ! common character variables
+ character (len=80) :: filename
+ character (len=8) :: snumber
+
+
+! transform the typical suffix into a character variable for the filename
+ if (ident>=0) then
+ write(snumber,'(1I7)') ident
+ else if (ident==-1) then
+ write(snumber,'(A8)') 'final'
+ else if (ident==-2) then
+ write(snumber,'(A8)') 'debug'
+ else if (ident==-3) then
+ write(snumber,'(A8)') 'ens_mean'
+ else if (ident==-4) then
+ write(snumber,'(A8)') 'mean'
+ else if (ident==-5) then
+ write(snumber,'(A8)') 'ens_mean'
+ end if
+!
+! ----- begin main body -----
+! ...
+! ------ end main body ------
+!
+ return
+
+ end subroutine write_user
diff --git a/user/wells3d/calc_user.f90 b/user/wells3d/calc_user.f90
new file mode 100644
index 0000000..5a61dd9
--- /dev/null
+++ b/user/wells3d/calc_user.f90
@@ -0,0 +1,187 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief initialisation routine for reinjection
+!> @param[in] ismpl local sample index
+ SUBROUTINE user_init(ismpl)
+ use arrays
+ use mod_genrl
+ use mod_linfos
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i
+
+ IF (linfos(3)>=2) WRITE(*,*) ' ... user_init (REINJECT-3D)'
+! avoid side effects
+ DO i = 1, nbc_data
+! init from the first set
+ dbc_dataold(i) = dbc_data(i,1,1)
+ END DO
+ RETURN
+ END
+
+!> @brief reinjection routine
+!> @param[in] ismpl local sample index
+!> @details
+!>injection 1 13 8 5\n
+!>injection 2 13 8 13\n
+!>injection 3 13 8 21\n
+!>production 1 13 18 5\n
+!>production 2 13 18 13\n
+!>production 3 13 18 21\n
+ SUBROUTINE calc_user(ismpl)
+ use arrays
+ use mod_genrl
+ use mod_time
+ use mod_linfos
+ use mod_wells3d
+ IMPLICIT NONE
+ integer :: ismpl
+ integer :: i, j
+
+
+ DOUBLE PRECISION tempc, pumpc, tempt, deltt
+ LOGICAL lbc_found, lbc_found1, lbc_found2
+ DOUBLE PRECISION deltat
+ EXTERNAL deltat
+ INTRINSIC dabs
+
+
+ IF (linfos(3)>=2) WRITE(*,*) ' ... calc_user (REINJECT-3D)'
+
+!VR --- special case, danger !!! ---
+
+ deltt = deltat(simtime(ismpl),ismpl)
+ IF ((simtime(ismpl)+deltt)/tunit>=stoptime) THEN
+ tempc = 0.D0
+ pumpc = 0.D0
+ tempt = 0.D0
+! for all productions
+ DO j = 1, num_pro
+ lbc_found = .FALSE.
+! search in all boundary condition
+ DO i = 1, nbc_data
+ IF (ibc_data(i,cbc_i)==ipro(j) .AND. &
+ ibc_data(i,cbc_j)==jpro(j) .AND. &
+ ibc_data(i,cbc_k)==kpro(j) .AND. &
+ ibc_data(i,cbc_pv)==pv_head .AND. &
+ ibc_data(i,cbc_bt)==bt_neum) THEN
+ IF (dbc_data(i,1,ismpl)>=0.D0) THEN
+ WRITE(*,'(2A,3I8,1A)') 'error: HEAD Neumann-boundary&
+ & point for production', &
+ ' has a value >= 0.0 at [', ipro(j), jpro(j), &
+ kpro(j), '] !'
+ STOP
+ END IF
+ lbc_found = .TRUE.
+ tempc = tempc + conc(ipro(j),jpro(j),kpro(j),1,ismpl)* &
+ dabs(dbc_data(i,1,ismpl))
+ tempt = tempt + temp(ipro(j),jpro(j),kpro(j),ismpl)* &
+ dabs(dbc_data(i,1,ismpl))
+ pumpc = pumpc + dabs(dbc_data(i,1,ismpl))
+ WRITE(*,'(1A,3(e12.4))') '!!!!! GPK2 center ', &
+ conc(ipro(j),jpro(j),kpro(j),1,ismpl), &
+ temp(ipro(j),jpro(j),kpro(j),ismpl), &
+ dbc_data(i,1,ismpl)
+ END IF
+ END DO
+ IF ( .NOT. lbc_found) THEN
+ WRITE(*,'(1A,3I8,1A)') 'error: no HEAD Neumann-boundary &
+ &point found for production [', ipro(j), jpro(j), &
+ kpro(j), '] !'
+ STOP
+ END IF
+ END DO
+
+ IF (pumpc/=0.D0) THEN
+ tempc = tempc/pumpc
+ tempt = tempt/pumpc
+ END IF
+
+ WRITE(*,'(4(1A,1e12.4))') '!!!!! reinjection rate = ', &
+ pumpc, ' l/s, concentration = ', tempc, &
+ ' mmol/l, temperature = ', tempt, ' C, time =', &
+ simtime(ismpl)
+
+! for all sources
+ DO j = 1, num_in
+ lbc_found = .FALSE.
+ lbc_found1 = .FALSE.
+ lbc_found2 = .FALSE.
+! search in all boundary condition
+ DO i = 1, nbc_data
+ IF (ibc_data(i,cbc_i)==iin(j) .AND. &
+ ibc_data(i,cbc_j)==jin(j) .AND. &
+ ibc_data(i,cbc_k)==kin(j) .AND. &
+ ibc_data(i,cbc_pv)==pv_conc .AND. &
+ ibc_data(i,cbc_bt)==bt_diri .AND. &
+ ibc_data(i,cbc_si)==1) THEN
+ dbc_data(i,1,ismpl) = tempc
+ lbc_found = .TRUE.
+ END IF
+ IF (ibc_data(i,cbc_i)==iin(j) .AND. &
+ ibc_data(i,cbc_j)==jin(j) .AND. &
+ ibc_data(i,cbc_k)==kin(j) .AND. &
+ ibc_data(i,cbc_pv)==pv_temp .AND. &
+ ibc_data(i,cbc_bt)==bt_diri) THEN
+ dbc_data(i,1,ismpl) = tempt
+ lbc_found1 = .TRUE.
+ END IF
+ IF (ibc_data(i,cbc_i)==iin(j) .AND. &
+ ibc_data(i,cbc_j)==jin(j) .AND. &
+ ibc_data(i,cbc_k)==kin(j) .AND. &
+ ibc_data(i,cbc_pv)==pv_head .AND. &
+ ibc_data(i,cbc_bt)==bt_neum) THEN
+ dbc_data(i,1,ismpl) = pumpc
+ lbc_found2 = .TRUE.
+ END IF
+ END DO
+ IF ( .NOT. lbc_found) THEN
+ WRITE(*,'(1A,3I8,1A)') 'error: no CONC Dirichlet-boundar&
+ &y point found for injection [', iin(j), jin(j), &
+ kin(j), '] !'
+ STOP
+ END IF
+ IF ( .NOT. lbc_found1) THEN
+ WRITE(*,'(1A,3I8,1A)') 'error: no TEMP Dirichlet-boundar&
+ &y point found for injection [', iin(j), jin(j), &
+ kin(j), '] !'
+ STOP
+ END IF
+ IF ( .NOT. lbc_found2) THEN
+ WRITE(*,'(1A,3I8,1A)') 'error: no HEAD Dirichlet-boundar&
+ &y point found for injection [', iin(j), jin(j), &
+ kin(j), '] !'
+ STOP
+ END IF
+ END DO
+ ELSE
+! reset the initial values
+ DO i = 1, nbc_data
+ dbc_data(i,1,ismpl) = dbc_dataold(i)
+ END DO
+ END IF
+
+!VR --- special case, danger !!! ---
+
+ RETURN
+ END
diff --git a/user/wells3d/mod_wells3d.f90 b/user/wells3d/mod_wells3d.f90
new file mode 100644
index 0000000..511973f
--- /dev/null
+++ b/user/wells3d/mod_wells3d.f90
@@ -0,0 +1,47 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief defines the reinjection parameters, user directory switch
+module mod_wells3d
+! number of IN sources
+ integer num_in
+ parameter (num_in = 1)
+! number of OUT productions
+ integer num_pro
+ parameter (num_pro = 1)
+!
+! finish time
+ double precision stoptime
+! 1d parameter (stoptime = 86400.d0)
+! 19 h!!!
+ parameter (stoptime = 68400.d0)
+!
+ integer iin(num_in), jin(num_in), kin(num_in)
+ integer ipro(num_pro), jpro(num_pro), kpro(num_pro)
+!
+ data iin /13/
+ data jin /8/
+ data kin /13/
+ data ipro /13/
+ data jpro /18/
+ data kpro /13/
+end module mod_wells3d
diff --git a/user/wells3d/user_check.f90 b/user/wells3d/user_check.f90
new file mode 100644
index 0000000..23a6658
--- /dev/null
+++ b/user/wells3d/user_check.f90
@@ -0,0 +1,50 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief check current user directory choice
+!> @param[in] ismpl local sample index
+ SUBROUTINE user_check(ismpl)
+ use mod_genrlc
+ IMPLICIT NONE
+ INTEGER ismpl
+ character (len=20) :: ldef_user
+ PARAMETER (ldef_user='wells3d')
+ LOGICAL test_option
+ EXTERNAL test_option
+ INTRINSIC trim
+
+#ifndef USER_wells3d
+ WRITE(*,'(3A)') 'error: this source was written for USER=', &
+ ldef_user, ', please correct this check in "user_check.f"!'
+ STOP
+#endif
+ IF ( .NOT. test_option('USER='//trim(def_user))) THEN
+ IF (ldef_user/=def_user) THEN
+ WRITE(*,'(7A)') 'error: model file needs an executable', &
+ ' build from USER=', trim(def_user), &
+ ', but the current', ' consist of USER=', &
+ trim(ldef_user), '!'
+ STOP
+ END IF
+ END IF
+ RETURN
+ END
diff --git a/user/wells3d/write_monitor_user.f90 b/user/wells3d/write_monitor_user.f90
new file mode 100644
index 0000000..1ab1dd8
--- /dev/null
+++ b/user/wells3d/write_monitor_user.f90
@@ -0,0 +1,81 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief writes data in tecplot-format (example routine)
+!> @param[in] otype orientation type:\n
+!> - 1 new file\n
+!> - 2 append\n
+!> @param[in] ismpl local sample index
+ subroutine write_monitor_user(otype,ismpl)
+
+ ! use mod_genrl, only: out_orientation
+ ! use mod_genrlc, only: project
+ ! use mod_time, only: simtime, tunit
+
+ implicit none
+
+ ! otype:
+ ! 1 new file
+ ! 2 append
+ integer, intent (in) :: otype
+
+ ! Samples index
+ integer :: ismpl
+
+ ! logical :: ltimes
+ ! logical :: lmonip
+ ! character (len=256) :: filename
+ ! integer, external :: lblank
+
+
+ ! ! Orientation of monitoring output
+ ! if (out_orientation==2 .or. out_orientation==3) then
+ ! ltimes = .true.
+ ! else
+ ! ltimes = .false.
+ ! end if
+
+ ! if (out_orientation==4) then
+ ! lmonip = .true.
+ ! else
+ ! lmonip = .false.
+ ! end if
+
+ ! ! Output Filename
+ ! call chln(project,i1,i2)
+ ! filename = project(i1:i2)//'_monitor_user.dat'
+
+ ! if (ltimes) then
+ ! write(filename,'(2A,1e14.8,1A)') &
+ ! project(i1:i2),'_', &
+ ! (simtime(ismpl))/tunit,'_monitor_user.dat'
+ ! endif
+
+ ! if (linfos(3).ge.2.and..not.lmonip) then
+ ! write(*,'(3A)') ' [W] : User Monitor points to "', &
+ ! filename(1:lblank(filename)),'"'
+ ! endif
+
+
+ return
+
+ end subroutine write_monitor_user
diff --git a/user/wells3d/write_user.f90 b/user/wells3d/write_user.f90
new file mode 100644
index 0000000..c6a4a0d
--- /dev/null
+++ b/user/wells3d/write_user.f90
@@ -0,0 +1,65 @@
+! MIT License
+!
+! Copyright (c) 2020 SHEMAT-Suite
+!
+! Permission is hereby granted, free of charge, to any person obtaining a copy
+! of this software and associated documentation files (the "Software"), to deal
+! in the Software without restriction, including without limitation the rights
+! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+! copies of the Software, and to permit persons to whom the Software is
+! furnished to do so, subject to the following conditions:
+!
+! The above copyright notice and this permission notice shall be included in all
+! copies or substantial portions of the Software.
+!
+! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+! SOFTWARE.
+
+!> @brief special output defined by the developer of this working directory (example routine)
+!> @param[in] ident iteration number
+!> @param[in] ismpl local sample index
+!> @details
+!> This routine can be taken as a starting point for writing
+!> additional user-defined output routines.
+ subroutine write_user(ident,ismpl)
+
+ implicit none
+
+ ! Sample index
+ integer :: ismpl
+
+ ! iteration number
+ integer, intent (in) ::ident
+
+ ! common character variables
+ character (len=80) :: filename
+ character (len=8) :: snumber
+
+
+! transform the typical suffix into a character variable for the filename
+ if (ident>=0) then
+ write(snumber,'(1I7)') ident
+ else if (ident==-1) then
+ write(snumber,'(A8)') 'final'
+ else if (ident==-2) then
+ write(snumber,'(A8)') 'debug'
+ else if (ident==-3) then
+ write(snumber,'(A8)') 'ens_mean'
+ else if (ident==-4) then
+ write(snumber,'(A8)') 'mean'
+ else if (ident==-5) then
+ write(snumber,'(A8)') 'ens_mean'
+ end if
+!
+! ----- begin main body -----
+! ...
+! ------ end main body ------
+!
+ return
+
+ end subroutine write_user
diff --git a/version.inc.in b/version.inc.in
new file mode 100644
index 0000000..0152c66
--- /dev/null
+++ b/version.inc.in
@@ -0,0 +1,15 @@
+! this file will be generated automatically - change the Makefile !!!
+! current version
+ character version*80
+ parameter (version = "@PROJECT_NAME@ @PROJECT_VERSION@ (@PROJECT_DESCRIPTION@)")
+! current date
+ character datum*40
+ parameter (datum = "@_configuration_time@")
+! build command line
+ character makecmd*256
+ parameter (makecmd = &
+ "PROPS=@PROPS@ "// &
+ "USER=@USER@ "// &
+ "COMPTYPE=@COMPTYPE@ "// &
+ "")
+
--
GitLab