diff --git a/KIM/tests/CMakeLists.txt b/KIM/tests/CMakeLists.txt index 2793d388..42934ace 100644 --- a/KIM/tests/CMakeLists.txt +++ b/KIM/tests/CMakeLists.txt @@ -24,7 +24,8 @@ add_executable(test_region_roots_vs_muller ${CMAKE_SOURCE_DIR}/KIM/tests/test_re set_target_properties(test_region_roots_vs_muller PROPERTIES OUTPUT_NAME test_region_roots_vs_muller.x RUNTIME_OUTPUT_DIRECTORY "${CMAKE_BINARY_DIR}/tests/") -target_link_libraries(test_region_roots_vs_muller KIM_lib kilca_lib lapack cerf fortnum_amos_compat) +target_link_libraries(test_region_roots_vs_muller KIM_lib kilca_lib lapack cerf fortnum_amos_compat + OpenMP::OpenMP_Fortran) add_test(NAME test_region_roots_vs_muller COMMAND ${CMAKE_BINARY_DIR}/tests/test_region_roots_vs_muller.x) diff --git a/KiLCA/CMakeLists.txt b/KiLCA/CMakeLists.txt index 48fdae1c..11c801c0 100644 --- a/KiLCA/CMakeLists.txt +++ b/KiLCA/CMakeLists.txt @@ -101,8 +101,8 @@ else () set (Jac ) endif () -set (kilca_normal_main progs/main_linear.cpp) -set (kilca_eigparam_main progs/main_eig_param.cpp) +set (kilca_normal_main progs/main_linear.f90) +set (kilca_eigparam_main progs/main_eig_param.f90) # Dependencies # Dependencies are provided by the top-level project via cmake/Dependencies.cmake @@ -110,7 +110,7 @@ set (kilca_eigparam_main progs/main_eig_param.cpp) # include paths: set (libs_root_path ${CMAKE_BINARY_DIR}/external-install) -set(EXTERNAL_LIBS fortnum_amos_compat lapack blas SUNDIALS::cvode SUNDIALS::nvecserial fortnum) +set(EXTERNAL_LIBS fortnum_amos_compat lapack blas SUNDIALS::cvode SUNDIALS::nvecserial fortnum sundials_fcvode_mod) # configure a header file to pass some of the CMake settings to the source code configure_file( @@ -148,56 +148,49 @@ include_directories ("${CMAKE_CURRENT_SOURCE_DIR}/spline") #cpp source files for kilca lib: set(kilca_lib_cpp_sources - core/shared.cpp - core/core.cpp - core/settings.cpp - core/output_sett.cpp - background/back_sett.cpp - background/background.cpp - background/calc_back.cpp - background/eval_back.cpp - eigmode/eigmode_sett.cpp - eigmode/calc_eigmode.cpp - eigmode/find_eigmodes.cpp - antenna/antenna.cpp - flre/flre_zone.cpp - flre/conductivity/calc_cond.cpp - flre/conductivity/cond_profs${interp}.cpp - flre/conductivity/eval_cond.cpp - flre/dispersion/disp_profs.cpp - flre/maxwell_eqs/eval_sysmat.cpp - flre/maxwell_eqs/maxwell_eqs_data.cpp - flre/maxwell_eqs/sysmat_profs.cpp - flre/quants/calc_flre_quants.cpp - flre/quants/flre_quants.cpp - hom_medium/hmedium_zone.cpp - imhd/compressible_flow.cpp - imhd/imhd_zone.cpp - imhd/incompressible.cpp - interface/wave_code_interface.cpp - interp/interp.cpp - io/inout.cpp - mode/mode.cpp - mode/calc_mode.cpp - mode/zone.cpp - mode/transforms.cpp - solver/solver.cpp - solver/rhs_func.cpp - spline/spline.cpp - math/hyper/hyper1F1.cpp - math/adapt_grid/adaptive_grid.cpp - math/adapt_grid/adaptive_grid_pol.cpp + math/zersol-0.0.0/src/zersolc.cpp ) #fortran source files for kilca lib: set(kilca_lib_fortran_sources core/constants_m${arch}.f90 + core/shared_m.f90 core/core_m.f90 + core/output_sett_m.f90 + core/settings_m.f90 + core/core_data_m.f90 + io/inout_m.f90 + progs/progs_common_m.f90 + interface/wave_code_interface_m.f90 + spline/spline_m.f90 + interp/neville_m.f90 + math/hyper/hyper1F1_m.f90 + math/adapt_grid/adaptive_grid_m.f90 + math/adapt_grid/adaptive_grid_pol_m.f90 antenna/antenna_m.f90 background/background_m.f90 + background/background_data_m.f90 + eigmode/eigmode_sett_m.f90 flre/flre_sett_m.f90 mode/mode_m.f90 + mode/wave_data_m.f90 + mode/transforms_m.f90 + mode/zone_m.f90 + mode/mode_data_m.f90 + eigmode/eigmode_solve_m.f90 + hom_medium/hmedium_zone_m.f90 + imhd/incompressible_m.f90 + imhd/compressible_flow_m.f90 + imhd/imhd_zone_m.f90 + interp/interp_m.f90 flre/maxwell_eqs/maxwell_eqs_m.f90 + flre/maxwell_eqs/maxwell_eqs_data_m.f90 + flre/maxwell_eqs/sysmat_profs_m.f90 + flre/dispersion/disp_profs_m.f90 + flre/conductivity/cond_profs_m.f90 + flre/quants/flre_quants_m.f90 + solver/solver_m.f90 + flre/flre_zone_m.f90 background/f0moments${Jac}.f90 background/density_p${Jac}.f90 antenna/antenna_spectrum.f90 @@ -240,6 +233,13 @@ set(kilca_lib_fortran_sources math/det/solve_hom_syst.f90 ) +# The C++ this file was ported from evaluated cos() through scalar libm +# (C/C++ math-errno semantics block libmvec); gfortran auto-vectorizes the +# Chebyshev-node loop to _ZGVbN2v_cos, whose last bits differ from scalar +# cos and shift the adaptive grid nodes off the golden record. +set_source_files_properties(math/adapt_grid/adaptive_grid_pol_m.f90 + PROPERTIES COMPILE_OPTIONS "-fno-tree-loop-vectorize") + add_library (kilca_lib STATIC ${kilca_lib_fortran_sources} ${kilca_lib_cpp_sources}) #add_library (kilca_lib SHARED ${kilca_lib_fortran_sources} ${kilca_lib_cpp_sources}) target_compile_options(kilca_lib PRIVATE -fPIC) @@ -293,6 +293,7 @@ add_executable (kilca_normal_exe ${kilca_normal_main}) set_target_properties(kilca_normal_exe PROPERTIES OUTPUT_NAME ${kilca_normal_exe} RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/install/bin/) +target_include_directories (kilca_normal_exe PRIVATE ${PROJECT_BINARY_DIR}/OBJS/kilca/) add_dependencies(kilca_normal_exe ${EXTERNAL_LIBS}) target_link_libraries (kilca_normal_exe kilca_lib ${EXTERNAL_LIBS}) @@ -300,16 +301,119 @@ add_executable (kilca_eigparam_exe ${kilca_eigparam_main}) set_target_properties(kilca_eigparam_exe PROPERTIES OUTPUT_NAME ${kilca_eigparam_exe} RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/install/bin/) +target_include_directories (kilca_eigparam_exe PRIVATE ${PROJECT_BINARY_DIR}/OBJS/kilca/) add_dependencies(kilca_eigparam_exe ${EXTERNAL_LIBS}) target_link_libraries (kilca_eigparam_exe kilca_lib ${EXTERNAL_LIBS}) -add_executable (post_proc post_processing/main_post_proc.cpp post_processing/save_fortran.f90) +add_executable (post_proc post_processing/main_post_proc.f90 post_processing/save_fortran.f90) set_target_properties(post_proc PROPERTIES OUTPUT_NAME post_processor_${KiLCA_ARCHITECTURE} RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/install/bin/) +target_include_directories (post_proc PRIVATE ${PROJECT_BINARY_DIR}/OBJS/kilca/) add_dependencies(post_proc ${EXTERNAL_LIBS}) target_link_libraries (post_proc kilca_lib ${EXTERNAL_LIBS}) +add_executable (test_spline tests/test_spline.f90) +set_target_properties(test_spline PROPERTIES + OUTPUT_NAME test_spline.x + RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/tests/) +target_include_directories (test_spline PRIVATE ${PROJECT_BINARY_DIR}/OBJS/kilca/) +add_dependencies(test_spline kilca_lib) +target_link_libraries (test_spline kilca_lib ${EXTERNAL_LIBS}) +add_test(NAME test_spline COMMAND ${CMAKE_BINARY_DIR}/tests/test_spline.x) + +add_executable (test_hyper1f1 tests/test_hyper1f1.f90) +set_target_properties(test_hyper1f1 PROPERTIES + OUTPUT_NAME test_hyper1f1.x + RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/tests/) +add_dependencies(test_hyper1f1 kilca_lib) +target_link_libraries (test_hyper1f1 kilca_lib ${EXTERNAL_LIBS}) +add_test(NAME test_hyper1f1 COMMAND ${CMAKE_BINARY_DIR}/tests/test_hyper1f1.x) + +add_executable (test_neville tests/test_neville.f90) +set_target_properties(test_neville PROPERTIES + OUTPUT_NAME test_neville.x + RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/tests/) +target_include_directories (test_neville PRIVATE ${PROJECT_BINARY_DIR}/OBJS/kilca/) +add_dependencies(test_neville kilca_lib) +target_link_libraries (test_neville kilca_lib ${EXTERNAL_LIBS}) +add_test(NAME test_neville COMMAND ${CMAKE_BINARY_DIR}/tests/test_neville.x) + +add_executable (test_antenna_settings tests/test_antenna_settings.f90) +set_target_properties(test_antenna_settings PROPERTIES + OUTPUT_NAME test_antenna_settings.x + RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/tests/) +add_dependencies(test_antenna_settings kilca_lib) +target_link_libraries (test_antenna_settings kilca_lib ${EXTERNAL_LIBS}) +add_test(NAME test_antenna_settings COMMAND ${CMAKE_BINARY_DIR}/tests/test_antenna_settings.x) +set_tests_properties(test_antenna_settings PROPERTIES WORKING_DIRECTORY ${CMAKE_BINARY_DIR}/tests/) + +add_executable (test_output_settings tests/test_output_settings.f90) +set_target_properties(test_output_settings PROPERTIES + OUTPUT_NAME test_output_settings.x + RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/tests/) +add_dependencies(test_output_settings kilca_lib) +target_link_libraries (test_output_settings kilca_lib ${EXTERNAL_LIBS}) +add_test(NAME test_output_settings COMMAND ${CMAKE_BINARY_DIR}/tests/test_output_settings.x) +set_tests_properties(test_output_settings PROPERTIES WORKING_DIRECTORY ${CMAKE_BINARY_DIR}/tests/) + +add_executable (test_back_sett tests/test_back_sett.f90) +set_target_properties(test_back_sett PROPERTIES + OUTPUT_NAME test_back_sett.x + RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/tests/) +add_dependencies(test_back_sett kilca_lib) +target_link_libraries (test_back_sett kilca_lib ${EXTERNAL_LIBS}) +add_test(NAME test_back_sett COMMAND ${CMAKE_BINARY_DIR}/tests/test_back_sett.x) +set_tests_properties(test_back_sett PROPERTIES WORKING_DIRECTORY ${CMAKE_BINARY_DIR}/tests/) + +add_executable (test_eigmode_sett tests/test_eigmode_sett.f90) +set_target_properties(test_eigmode_sett PROPERTIES + OUTPUT_NAME test_eigmode_sett.x + RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/tests/) +add_dependencies(test_eigmode_sett kilca_lib) +target_link_libraries (test_eigmode_sett kilca_lib ${EXTERNAL_LIBS}) +add_test(NAME test_eigmode_sett COMMAND ${CMAKE_BINARY_DIR}/tests/test_eigmode_sett.x) +set_tests_properties(test_eigmode_sett PROPERTIES WORKING_DIRECTORY ${CMAKE_BINARY_DIR}/tests/) + +# Standalone: links maxwell_eqs_data_m.f90 + fakes only, NOT kilca_lib, since +# the fakes intentionally redefine the same C-ABI symbols maxwell_eqs_m.f90 +# (inside kilca_lib) provides for real zones. +add_executable (test_maxwell_eqs_data + flre/maxwell_eqs/maxwell_eqs_data_m.f90 + tests/test_maxwell_eqs_data_fakes.f90 + tests/test_maxwell_eqs_data.f90) +set_target_properties(test_maxwell_eqs_data PROPERTIES + OUTPUT_NAME test_maxwell_eqs_data.x + RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/tests/ + Fortran_MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/OBJS/test_maxwell_eqs_data/) +add_test(NAME test_maxwell_eqs_data COMMAND ${CMAKE_BINARY_DIR}/tests/test_maxwell_eqs_data.x) + +# Standalone: links disp_profs_m.f90 + fakes only, NOT kilca_lib, since the +# fakes intentionally redefine calc_dispersion/save_cmplx_matrix_to_one_file. +add_executable (test_disp_profiles + flre/dispersion/disp_profs_m.f90 + tests/test_disp_profiles_fakes.f90 + tests/test_disp_profiles.f90) +set_target_properties(test_disp_profiles PROPERTIES + OUTPUT_NAME test_disp_profiles.x + RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/tests/ + Fortran_MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/OBJS/test_disp_profiles/) +add_test(NAME test_disp_profiles COMMAND ${CMAKE_BINARY_DIR}/tests/test_disp_profiles.x) + +# Standalone: links sysmat_profs_m.f90 + fakes + fortnum (for argsort) only, +# NOT kilca_lib, since the fakes intentionally redefine calc_diff_sys_matrix_/ +# calc_adaptive_1D_grid_4vector_/spline_alloc_/spline_calc_/save_cmplx_matrix. +add_executable (test_sysmat_profiles + flre/maxwell_eqs/sysmat_profs_m.f90 + tests/test_sysmat_profiles_fakes.f90 + tests/test_sysmat_profiles.f90) +set_target_properties(test_sysmat_profiles PROPERTIES + OUTPUT_NAME test_sysmat_profiles.x + RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/tests/ + Fortran_MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/OBJS/test_sysmat_profiles/) +target_link_libraries (test_sysmat_profiles fortnum) +add_test(NAME test_sysmat_profiles COMMAND ${CMAKE_BINARY_DIR}/tests/test_sysmat_profiles.x) + # add a target to generate API documentation with Doxygen find_package (Doxygen) diff --git a/KiLCA/antenna/antenna.cpp b/KiLCA/antenna/antenna.cpp deleted file mode 100644 index 23a2aa1e..00000000 --- a/KiLCA/antenna/antenna.cpp +++ /dev/null @@ -1,130 +0,0 @@ -/*! \file antenna.cpp - \brief The implementation of antenna class. -*/ - -#include -#include -#include -#include - -#include "antenna.h" -#include "inout.h" - -/*-----------------------------------------------------------------*/ - -void antenna::read_settings (char *path) -{ -/*! \fn read_settings (char *path) - \brief - - \param path path to top level run dir of a project. -*/ - -char *file_set = new char[1024]; - -sprintf (file_set, "%s/antenna.in", path); - -FILE *in; - -if ((in=fopen (file_set, "r"))==NULL) -{ - fprintf(stderr, "\nerror: read_antenna_settings: failed to open file %s\a\n", file_set); - exit(0); -} - -//reading: check for consistence with the input file! -char *str_buf = new char[1024]; //str buffer - -//Antenna settings: -read_line_2skip_it (in, &str_buf); -read_line_2get_double (in, &(ra)); -read_line_2get_double (in, &(wa)); -read_line_2get_double (in, &(I0)); -read_line_2get_complex (in, &(flab)); -read_line_2get_int (in, &(dma)); -read_line_2get_int (in, &(flag_debug)); -read_line_2get_int (in, &(flag_eigmode)); -read_line_2skip_it (in, &str_buf); - -fclose (in); - -int i; - -//Reading modes.in file: -sprintf (file_set, "%s/modes.in", path); - -if ((in=fopen (file_set, "r"))==NULL) -{ - fprintf(stderr, "\nerror: read_antenna_settings: failed to open file %s\a\n", file_set); - exit(0); -} - -modes = new int[2*dma]; //(m,n) -for (i=0; ira; -*wa = ap->wa; -*I0 = ap->I0; -*flab_re = real(ap->flab); -*flab_im = imag(ap->flab); -*dma = ap->dma; -*flag_debug = ap->flag_debug; -} - -/*-----------------------------------------------------------------*/ diff --git a/KiLCA/antenna/antenna.h b/KiLCA/antenna/antenna.h deleted file mode 100644 index 1817fa7f..00000000 --- a/KiLCA/antenna/antenna.h +++ /dev/null @@ -1,52 +0,0 @@ -/*! \file antenna.h - \brief The declaration of antenna class representing the antenna settings. -*/ - -#ifndef ANTENNA_INCLUDE - -#define ANTENNA_INCLUDE - -#include - -#include "constants.h" - -/*! \class antenna - \brief The class contains the antenna parameters. -*/ -class antenna -{ -public: - double ra; //! flab; //!debug flag - - int flag_eigmode; //! Read antenna.in and modes.in into the antenna_data module, replacing the +!> former C++ antenna::read_settings. Each scalar line is "value #comment"; the +!> value before '#' is read list-directed, so the complex flab parses from its +!> (re, im) form natively. modes.in holds dma lines "(m,n)". +subroutine read_antenna_settings(path) bind(C, name="read_antenna_settings_") + +use, intrinsic :: iso_c_binding, only: c_char, c_null_char +use, intrinsic :: iso_fortran_env, only: error_unit +use antenna_data + +character(kind=c_char), dimension(*), intent(in) :: path + +character(len=1024) :: fpath, fname, line, before +integer :: i, u, ios, hp, k + +fpath = '' +i = 1 +do + if (path(i) == c_null_char .or. i > 1024) exit + fpath(i:i) = path(i) + i = i + 1 +end do + +fname = trim(fpath)//'/antenna.in' +open (newunit=u, file=trim(fname), status='old', action='read', iostat=ios) +if (ios /= 0) then + write (error_unit, '(a,a)') "error: read_antenna_settings: cannot open ", trim(fname) + error stop +end if + +read (u, '(a)', iostat=ios) line ! header line +call value_before_hash(u, before); read (before, *) ra +call value_before_hash(u, before); read (before, *) wa +call value_before_hash(u, before); read (before, *) I0 +call value_before_hash(u, before); read (before, *) flab +call value_before_hash(u, before); read (before, *) dma +call value_before_hash(u, before); read (before, *) flag_debug +call value_before_hash(u, before); read (before, *) flag_eigmode +close (u) + +fname = trim(fpath)//'/modes.in' +open (newunit=u, file=trim(fname), status='old', action='read', iostat=ios) +if (ios /= 0) then + write (error_unit, '(a,a)') "error: read_antenna_settings: cannot open ", trim(fname) + error stop +end if + +if (allocated(modes)) deallocate (modes) +allocate (modes(2*dma)) +do k = 0, dma - 1 + read (u, '(a)', iostat=ios) line + if (ios /= 0) then + write (error_unit, '(a)') "error: read_antenna_settings: modes.in read error" + error stop + end if + do i = 1, len(line) + if (line(i:i) == '(' .or. line(i:i) == ')' .or. line(i:i) == ',') line(i:i) = ' ' + end do + read (line, *) modes(2*k + 1), modes(2*k + 2) +end do +close (u) + +if (flag_debug > 0) call print_antenna_module_data() + +contains + + subroutine value_before_hash(unit, out) + integer, intent(in) :: unit + character(len=*), intent(out) :: out + character(len=1024) :: buf + integer :: pos, jos + read (unit, '(a)', iostat=jos) buf + if (jos /= 0) then + write (error_unit, '(a)') "error: read_antenna_settings: antenna.in read error" + error stop + end if + pos = index(buf, '#') + if (pos > 0) then + out = buf(1:pos - 1) + else + out = buf + end if + end subroutine value_before_hash + +end subroutine read_antenna_settings -use constants, only: pp, dp, im; -use antenna_data; - -integer(pp), intent(in) :: as -real(dp) :: flab_re, flab_im; - -call set_antenna_settings_c (as, ra, wa, I0, flab_re, flab_im, dma, flag_debug); - -flab = flab_re + im*flab_im; - -!array 'modes' is not set! +!------------------------------------------------------------------------------ -if (flag_debug > 0) call print_antenna_module_data (); +integer(c_int) function get_antenna_dma() bind(C, name="get_antenna_dma_") + use, intrinsic :: iso_c_binding, only: c_int + use antenna_data, only: dma + get_antenna_dma = dma +end function + +subroutine get_antenna_flab(re, im) bind(C, name="get_antenna_flab_") + use, intrinsic :: iso_c_binding, only: c_double + use antenna_data, only: flab + real(c_double), intent(out) :: re, im + re = real(flab, c_double) + im = aimag(flab) +end subroutine +subroutine get_antenna_mode(ind, m, n) bind(C, name="get_antenna_mode_") + use, intrinsic :: iso_c_binding, only: c_int + use antenna_data, only: modes + integer(c_int), value :: ind + integer(c_int), intent(out) :: m, n + m = modes(2*ind + 1) + n = modes(2*ind + 2) end subroutine +real(c_double) function get_antenna_ra() bind(C, name="get_antenna_ra_") + use, intrinsic :: iso_c_binding, only: c_double + use antenna_data, only: ra + get_antenna_ra = ra +end function + +real(c_double) function get_antenna_wa() bind(C, name="get_antenna_wa_") + use, intrinsic :: iso_c_binding, only: c_double + use antenna_data, only: wa + get_antenna_wa = wa +end function + +integer(c_int) function get_antenna_flag_eigmode() bind(C, name="get_antenna_flag_eigmode_") + use, intrinsic :: iso_c_binding, only: c_int + use antenna_data, only: flag_eigmode + get_antenna_flag_eigmode = flag_eigmode +end function + !------------------------------------------------------------------------------ subroutine set_current_density_in_antenna_module () diff --git a/KiLCA/background/back_sett.cpp b/KiLCA/background/back_sett.cpp deleted file mode 100644 index c9bc1655..00000000 --- a/KiLCA/background/back_sett.cpp +++ /dev/null @@ -1,152 +0,0 @@ -/*! \file back_sett.cpp - \brief The implementation of back_sett class. -*/ - -#include -#include -#include -#include -#include -#include - -#include "constants.h" -#include "back_sett.h" -#include "inout.h" -#include "shared.h" - -/*-----------------------------------------------------------------*/ - -void back_sett::read_settings (char *path) -{ -char *file_set = new char[1024]; - -sprintf (file_set, "%s/background.in", path); - -FILE *in; - -if ((in=fopen (file_set, "r"))==NULL) -{ - fprintf(stderr, "\nerror: read_background_settings: failed to open file %s\a\n", file_set); - exit(0); -} - -//reading: check for consistence with file! -char *str_buf = new char[1024]; //str buffer - -//Machine settings: -read_line_2skip_it (in, &str_buf); -read_line_2get_double (in, &(rtor)); -read_line_2get_double (in, &(rp)); -read_line_2get_double (in, &(B0)); -read_line_2skip_it (in, &str_buf); - -//Backround field and plasma settings: -read_line_2skip_it (in, &str_buf); -path2profiles = new char[1024]; -read_line_2get_string (in, &(path2profiles)); -read_line_2get_int (in, &(calc_back)); -flag_back = new char[8]; -read_line_2get_string (in, &(flag_back)); -read_line_2get_int (in, &(N)); -read_line_2get_double (in, &(V_gal_sys)); -read_line_2get_double (in, &(V_scale)); -read_line_2get_double (in, &(m_i)); -read_line_2get_double (in, &(zele)); -read_line_2get_double (in, &(zion)); -read_line_2skip_it (in, &str_buf); - -//Checkings setting: -read_line_2skip_it (in, &str_buf); -read_line_2get_int (in, &(flag_debug)); -read_line_2skip_it (in, &str_buf); - -fclose (in); - -delete [] str_buf; -delete [] file_set; - -//Particles settings: -mass = new double[2]; -charge = new double[2]; - -mass[0] = (m_i)*m_p; /*ions mass*/ -mass[1] = m_e; /*electrons mass*/ - -charge[0] = e; //ions charge -charge[1] = -e; //electrons charge - -huge_factor = 1.0e20; - -if (flag_debug) print_settings (); -} - -/*-----------------------------------------------------------------*/ - -void back_sett::print_settings (void) -{ -fprintf(stdout, "\nCheck for background parameters below:\n"); - -//Machine settings: -fprintf (stdout, "\ntorus big radius: %lg cm", rtor); -fprintf (stdout, "\nplasma radius: %lg cm", rp); -fprintf (stdout, "\ntoroidal magnetic field at the center: %lg G", B0); - -//Backround field and plasma settings: -fprintf (stdout, "\npath to background profiles: %s", path2profiles); -fprintf (stdout, "\nflag if recalculate background: %d", calc_back); -fprintf (stdout, "\nflag for background: %s", flag_back); -fprintf (stdout, "\nsplines degree: %d", N); -fprintf (stdout, "\nvelocity of the moving frame: %lg cm/s", V_gal_sys); -fprintf (stdout, "\nscale factor for the Vz velocity profile: %lg", V_scale); -fprintf (stdout, "\nions mass in units of proton mass: %lg", m_i); -fprintf (stdout, "\ncollision coefficient for electrons: %lg", zele); -fprintf (stdout, "\ncollision coefficient for ions: %lg", zion); -fprintf (stdout, "\nflag for debugging mode: %d", flag_debug); - -fprintf(stdout, "\n"); -} - -/*-----------------------------------------------------------------*/ - -void set_background_settings_c_ (back_sett **bsett, double *rtor, double *rp, double *B0, char *flag_back, double *V_gal_sys, double *V_scale, double *zele, double *zion, int *flag_debug) -{ -back_sett *bs = (back_sett *)(*bsett); - -*rtor = bs->rtor; -*rp = bs->rp; -*B0 = bs->B0; - -*flag_back = bs->flag_back[0]; - -*V_gal_sys = bs->V_gal_sys; -*V_scale = bs->V_scale; - -*zele = bs->zele; -*zion = bs->zion; - -*flag_debug = bs->flag_debug; -} - -/*-----------------------------------------------------------------*/ - -void set_particles_settings_c_ (back_sett **bsett, double *mass, double *charge) -{ -back_sett *bs = (back_sett *)(*bsett); - -mass[0] = bs->mass[0]; -mass[1] = bs->mass[1]; - -charge[0] = bs->charge[0]; -charge[1] = bs->charge[1]; -} - -/*-----------------------------------------------------------------*/ - -void set_huge_factor_c_ (back_sett **bsett, double *fac) -{ -back_sett *bs = (back_sett *)(*bsett); - -*fac = bs->huge_factor; -} - -/*-----------------------------------------------------------------*/ diff --git a/KiLCA/background/back_sett.h b/KiLCA/background/back_sett.h deleted file mode 100644 index d4af53d4..00000000 --- a/KiLCA/background/back_sett.h +++ /dev/null @@ -1,78 +0,0 @@ -/*! \file back_sett.h - \brief The declaration of back_sett class representing background settings. -*/ - -#ifndef BACK_SETT_INCLUDE - -#define BACK_SETT_INCLUDE - -/*! \class back_sett - \brief The class for background settings. -*/ -class back_sett -{ -public: - ///Machine settings: - double rtor; //!= NC + 2N+1, where N - order of flr expansion, NC - spl degree for C matrices, must be odd - - double V_gal_sys; //! -#include -#include -#include -#include -#include - -#include "background.h" -#include "back_sett.h" -#include "calc_back.h" -#include "inout.h" -#include "spline.h" - -#include "shared.h" -#include "constants.h" -#include "conduct_parameters.h" -#include "wave_code_interface.h" - -/*-----------------------------------------------------------------*/ - -background::background (const settings *s) -{ -sd = s; - -set_profiles_indices (); - -//for moments computation: -set_back_aliases_in_conductivity_parameters_ (); - -path2background = new char[1024]; - -sprintf (path2background, "%s%s", sd->path2project, "background-data/"); - -if (sd->os->flag_background > 1) -{ - //make dir for background data: - char *sys_command = new char[1024]; - - sprintf (sys_command, "%s%s", "mkdir -p ", path2background); - - if (system (sys_command)==-1) - { - fprintf (stderr, "\nerror: set_background_profiles: system()!"); - } - - delete [] sys_command; -} -} - -/*-----------------------------------------------------------------*/ - -background::~background (void) -{ -for (int k=0; kbs->calc_back) == 1 || abs(sd->bs->calc_back) == 3) Nprofiles = 7; //q, n, Ti, Te, Vth, Vz, Er -else if (abs(sd->bs->calc_back) == 2) Nprofiles = 11; //q, n, Ti, Te, Vth, Vz, Er, Bth, Bz, Jth, Jz -else -{ - fprintf (stderr, "\nwarning: set_profiles_indices: unknown flag!\n"); - exit(1); -} - -profile_names = new char *[Nprofiles]; - -int k; - -for (k=0; kbs->calc_back) == 1 || abs(sd->bs->calc_back) == 3) -{ - strcpy (profile_names[0], "q"); - strcpy (profile_names[1], "n"); - strcpy (profile_names[2], "Ti"); - strcpy (profile_names[3], "Te"); - strcpy (profile_names[4], "Vth"); - strcpy (profile_names[5], "Vz"); - strcpy (profile_names[6], "Er"); -} -else if (abs(sd->bs->calc_back) == 2) -{ - strcpy (profile_names[0], "q"); - strcpy (profile_names[1], "n"); - strcpy (profile_names[2], "Ti"); - strcpy (profile_names[3], "Te"); - strcpy (profile_names[4], "Vth"); - strcpy (profile_names[5], "Vz"); - strcpy (profile_names[6], "Er"); - strcpy (profile_names[7], "Bth"); - strcpy (profile_names[8], "Bz"); - strcpy (profile_names[9], "Jth"); - strcpy (profile_names[10], "Jz"); -} - -/*background splines indices: the order of indices below is VERY important and offers the best convenience: DO NOT CHANGE, ONLY ADD NEW IF NEEDED!!!*/ -k = 0; - -i_q = k++; - -i_n = k++; - -i_T = new int[2]; /*i,e*/ -i_T[0] = k++; -i_T[1] = k++; - -i_Vth = new int[3]; /*i,e,t*/ -i_Vz = new int[3]; /*i,e,t*/ - -i_Vth[2] = k++; -i_Vz[2] = k++; - -i_Er = k++; - -/*from equlibrium:*/ -i_Bth = k++; - -i_Bz = k++; - -i_B = k++; - -i_hth = k++; - -i_hz = k++; - -i_dPhi0 = k++; - -/*from f0 parameters search:*/ -i_n_p = new int[2]; /*i,e*/ -i_Vp_p = new int[2]; /*i,e*/ -i_Vt_p = new int[2]; /*i,e*/ -i_nu = new int[2]; /*i,e*/ - -i_n_p[0] = k++; -i_Vp_p[0] = k++; -i_Vt_p[0] = k++; -i_nu[0] = k++; - -i_n_p[1] = k++; -i_Vp_p[1] = k++; -i_Vt_p[1] = k++; -i_nu[1] = k++; - -/*from equlibrium:*/ -i_J0th = new int[3]; /*i,e,t*/ -i_J0z = new int[3]; /*i,e,t*/ - -i_J0th[2] = k++; -i_J0z[2] = k++; - -i_J0th[1] = k++; -i_J0z[1] = k++; - -i_J0th[0] = k++; -i_J0z[0] = k++; - -i_Vth[1] = k++; -i_Vz[1] = k++; - -i_Vth[0] = k++; -i_Vz[0] = k++; - -dimy = k; /*total number of background profiles*/ -} - -/*-----------------------------------------------------------------*/ - -void background::set_background_profiles_from_files (void) -{ -char *file_name = new char[1024]; -sprintf (file_name, "%sn.dat", sd->bs->path2profiles); - -/*arrays allocation for background profiles:*/ -dimx = count_lines_in_file (file_name, 0); - -delete [] file_name; - -int N = sd->bs->N; - -ind = (int)0.5*(dimx); - -x = new double[dimx]; - -y = new double[(dimx)*(dimy)]; - -C = new double[(N+1)*(dimx)*(dimy)]; - -R = new double[(N+1)*(dimy)]; - -spline_alloc_ (N, 1, dimx, x, C, &(sid)); - -//load and spline input profiles: -int ierr; -ierr = load_input_background_profiles (); -//fprintf (stdout, "\nbackground profiles are loaded...\n"); - -ierr = spline_input_profiles (); //first 7 profs, see later -//fprintf (stdout, "\nbackground profiles are splined...\n"); - -if (abs(sd->bs->calc_back) == 1) -{ - ierr = calculate_equilibrium (); - //fprintf (stdout, "\nequilibrium parameters are computed...\n"); -} -else if (abs(sd->bs->calc_back) == 2) -{ - ierr = check_and_spline_equilibrium (); - //fprintf (stdout, "\ninput equilibrium is checked...\n"); -} -else -{ - fprintf (stderr, "\nset_background_profiles_from_files: this feature is not implemented yet!\n"); - exit(1); -} - -flag_dPhi0_calc = 1; //to recalculate dPhi0 - -//to get background electric field never use Er array - it is in the lab frame. Always use dPhi0! - -ierr = find_f0_parameters (); -//fprintf (stdout, "\nf0 parameters are computed...\n"); - -if (sd->os->flag_background > 1) -{ - save_background (); - //fprintf (stdout, "\nbackground quantities are stored...\n"); - - //independent computation of f0 moments for checking: - eval_and_save_f0_moments (); - //fprintf (stdout, "\nf0 moments are computed and stored...\n"); -} -} - -/*-----------------------------------------------------------------*/ - -void background::set_background_profiles_from_interface (void) -{ -get_background_dimension_from_balance_ (&dimx); - -ind = (int)0.5*(dimx); - -int N = sd->bs->N; - -x = new double[dimx]; - -y = new double[(dimx)*(dimy)]; - -C = new double[(N+1)*(dimx)*(dimy)]; - -R = new double[(N+1)*(dimy)]; - -spline_alloc_ (N, 1, dimx, x, C, &(sid)); - -double *q = y + (i_q)*dimx; -double *n = y + (i_n)*dimx; -double *Ti = y + (i_T[0])*dimx; -double *Te = y + (i_T[1])*dimx; -double *Vth = y + (i_Vth[2])*dimx; -double *Vz = y + (i_Vz[2])*dimx; -double *Er = y + (i_Er)*dimx; - -get_background_profiles_from_balance_ (&dimx, x, q, n, Ti, Te, Vth, Vz, Er); - -//transform background profiles to a moving frame -//Er is not transformed, but dPhi0 is transformed later in find_f0_parameters -for (int i=0; ibs->V_gal_sys; - -int ierr; - -ierr = spline_input_profiles (); - -// recalculate dPhi0 in find_f0_parameters to match file-based mode behavior -flag_dPhi0_calc = 1; - -if (abs(sd->bs->calc_back) == 1) -{ - ierr = calculate_equilibrium (); - //fprintf (stdout, "\nequilibrium parameters are computed...\n"); -} -else if (abs(sd->bs->calc_back) == 2) -{ - //ierr = check_and_spline_equilibrium (); - fprintf (stderr, "\nset_background_profiles_from_interface: this feature is not implemented yet!\n"); - exit(1); -} -else if (abs(sd->bs->calc_back) == 3) -{ - flag_dPhi0_calc = 1; - ierr = calculate_equilibrium (); - //fprintf (stdout, "\nequilibrium parameters are computed...\n"); -} -else -{ - fprintf (stderr, "\nset_background_profiles_from_files: this feature is not implemented yet!\n"); - exit(1); -} - -ierr = find_f0_parameters (); - -if (sd->os->flag_background > 1) -{ - save_background (); - - eval_and_save_f0_moments (); //independent computation of f0 moments for checking -} -} - -/*-----------------------------------------------------------------*/ - -int background::load_input_background_profiles (void) -{ -//all profiles are assumed to be in the lab frame, Vz profile is shifted to a moving frame, but Er not! - -int i, j; -double tmp1 = 0, tmp2 = 0; - -char *file_name = new char[1024]; -char *sys_command = new char[1024]; - -int ind[11] = {i_q, i_n, i_T[0], i_T[1], i_Vth[2], i_Vz[2], i_Er, i_Bth, i_Bz, i_J0th[2], i_J0z[2]}; - -/*loading profiles*/ -for (i=0; ibs->path2profiles, profile_names[i]); - load_data_file (file_name, dimx, 1, x, y+ind[i]*dimx); - - if (i==5) //shift (negative) and scale Vz profile: - { - for (j=0; jbs->V_scale; //scale Vz profile - *(y+ind[i]*dimx+j) -= sd->bs->V_gal_sys; //shift Vz profile - } - } - - /*check for r grid: must be the same for all profiles:*/ - tmp2 = 0.0e0; - for (j=0; jos->flag_background > 1) - { - /*copy input profile to background-data dir*/ - sprintf (sys_command, "%s%s%s%s%s%s", "cp ", file_name, " ", path2background, profile_names[i], "_i.dat"); - system (sys_command); - } -} - -if (x[0]==0.0) -{ - fprintf (stderr, "\nwarning: load_input_profiles: first point of profiles grid must be not zero!\n"); -} - -delete [] file_name; -delete [] sys_command; - - - -return 0; -} - -/*-----------------------------------------------------------------*/ - -int background::spline_input_profiles (void) -{ -/*splines first 7 profiles: q, n, Ti, Te, Vth, Vz (in mov frame), Er (in lab frame)*/ -int ierr; - -spline_calc_ (sid, y + i_q, i_q, i_Er, NULL, &ierr); - -return ierr; -} - -/*-----------------------------------------------------------------*/ diff --git a/KiLCA/background/background.h b/KiLCA/background/background.h deleted file mode 100644 index c7394076..00000000 --- a/KiLCA/background/background.h +++ /dev/null @@ -1,112 +0,0 @@ -/*! \file background.h - \brief The declaration of background class representing background profiles and other data. -*/ - -#ifndef BACKGROUND_INCLUDE - -#define BACKGROUND_INCLUDE - -#include - -#include "settings.h" - -/*! \class background - \brief The class for background profiles and data. -*/ -class background -{ -public: - const settings *sd; //! Background equilibrium profiles and physics, formerly the C++ background +!> class (background.{h,cpp} + calc_back.cpp + eval_back.cpp). Translated as +!> a Fortran SINGLETON module, not a per-instance handle: the only live +!> `new background(...)` call site anywhere in the tree is core.cpp's +!> calc_and_set_mode_independent_core_data, called exactly once per run (the +!> other `new background` hit, post_processing/torque_facs.cpp, is dead - +!> not in any CMake target, like transf_quants.cpp/quants_profs.h which it +!> belongs to). +!> +!> bp_ptr (core_m.f90) is read by ~10 existing live Fortran files +!> (conduct_parameters.f90's eval_and_set_background_parameters_spec_ +!> independent/_spec_dependent/eval_and_set_f0_parameters_nu_and_derivs, and +!> transitively gcorr.f90/kmatrices*.f90/diff_sys.f90) as an opaque handle +!> passed to the (formerly C++) eval_background_spec_independent_/ +!> eval_f0_parameters_nu_and_derivs_/vs_0_f_/eval_hthz_ extern "C" functions, +!> which dereferenced it as `background*`. Since background is now a +!> singleton with no heap address to hand out, bp_ptr is kept only as a +!> harmless nonzero sentinel (set once by background_create_) so none of +!> those ~10 existing Fortran files need editing; the bind(C) functions +!> below still accept a handle argument to match those callers' existing +!> argument lists exactly, but ignore its value and operate on this +!> module's own state. +module kilca_background_data_m + use, intrinsic :: iso_c_binding + use, intrinsic :: iso_fortran_env, only: error_unit, output_unit + use constants, only: dp, pi, boltz, mp, me, e + use kilca_spline_m, only: spline_alloc, spline_calc, spline_eval, spline_free + use fortnum_status, only: fortnum_status_t, FORTNUM_OK + use fortnum_ode_rk8pd, only: rk8pd_state_t, rk8pd_evolve_init, rk8pd_evolve_apply + use background, only: flag_back, calc_back, N, path2profiles, & + rtor, B0, V_gal_sys, V_scale, mass, charge, zion, zele, flag_debug + implicit none + private + + !> Speed of light at full double precision, mirroring the C++ oracle's + !> constants.h (const double c = 29979245800.0) that this ported code + !> descends from. The Fortran constants module keeps a legacy + !> single-precision c for its own (unported) physics; see that module. + real(dp), parameter :: c = 29979245800.0_dp + + public :: background_create, background_set_profiles_from_files + public :: background_set_profiles_from_interface + public :: background_interp_in_lab_frame + public :: eval_background_spec_independent, eval_f0_parameters_nu_and_derivs + public :: vs_0_f + public :: eval_hthz_c, eval_hthz + public :: eval_Bt_dBt_Bz_dBz, eval_p_dp, eval_mass_density, eval_Bt_Bz + public :: eval_Bt, eval_Bz, eval_Vt, eval_Vz, eval_B0_ht_hz_n0_Vz + public :: get_background_x0, get_background_xlast, get_background_dimx + + integer(c_int) :: Nprofiles + character(len=8), allocatable :: profile_names(:) + character(len=1024) :: path2background + + integer(c_int) :: dimx + real(dp), allocatable, target :: x(:) + + integer(c_int) :: dimy + real(dp), allocatable, target :: y(:) + + integer(c_int) :: ind_search + real(dp), allocatable, target :: Carr(:) + real(dp), allocatable, target :: Rarr(:) + + integer(c_intptr_t) :: sid = 0 + + integer(c_int) :: i_q, i_n + integer(c_int) :: i_T(0:1) + integer(c_int) :: i_Vth(0:2), i_Vz(0:2) + integer(c_int) :: i_Er + integer(c_int) :: i_hth, i_hz, i_Bth, i_Bz, i_B + integer(c_int) :: i_J0th(0:2), i_J0z(0:2) + integer(c_int) :: i_dPhi0 + integer(c_int) :: i_n_p(0:1), i_Vp_p(0:1), i_Vt_p(0:1), i_nu(0:1) + + integer(c_int) :: flag_dPhi0_calc + + interface + integer(c_int) function get_output_flag_background() bind(C, name="get_output_flag_background_") + import :: c_int + end function get_output_flag_background + + function eval_path_to_linear_data_c(buf) result(n) bind(C) + import :: c_int, c_char + character(kind=c_char), intent(in) :: buf(*) + integer(c_int) :: n + end function eval_path_to_linear_data_c + + !> Was wrongly bound to "count_lines_in_file_" (a 3-arg void C + !> wrapper, `count_lines_in_file_(char*,int*,int*)`) with only 1 of + !> its args declared and treated as a function returning a value - + !> a genuine ABI mismatch (1 arg passed where 3 were expected, a + !> function call against a void target) that the test suite never + !> exercised since count_lines() below is only reached via the + !> background_set_profiles_from_files_ path. Fixed to bind directly + !> to "count_lines_in_file" (the real 2-arg function, filename + + !> flag_print) with both arguments declared. + function count_lines_in_file_c(filename, flag_print) result(n) & + bind(C, name="count_lines_in_file") + import :: c_int, c_char + character(kind=c_char), intent(in) :: filename(*) + integer(c_int), value :: flag_print + integer(c_int) :: n + end function count_lines_in_file_c + + function load_data_file_c(file_name, dim_, ncols, rgrid, qgrid) result(ierr) & + bind(C, name="load_data_file") + import :: c_int, c_char, c_double + character(kind=c_char), intent(in) :: file_name(*) + integer(c_int), value :: dim_, ncols + real(c_double), intent(in) :: rgrid(*) + real(c_double), intent(out) :: qgrid(*) + integer(c_int) :: ierr + end function load_data_file_c + + integer(c_int) function save_real_array_c(dim_, xgrid, arr, full_name) & + bind(C, name="save_real_array") + import :: c_int, c_double, c_char + integer(c_int), value :: dim_ + real(c_double), intent(in) :: xgrid(*), arr(*) + character(kind=c_char), intent(in) :: full_name(*) + end function save_real_array_c + + function get_background_dimension_from_balance_c(dimx_) result(stat) & + bind(C, name="get_background_dimension_from_balance_") + import :: c_int + integer(c_int), intent(out) :: dimx_ + integer(c_int) :: stat + end function get_background_dimension_from_balance_c + end interface + + interface + subroutine get_background_profiles_from_balance_x(dimx_, x_, q_, n_, Ti_, Te_, Vth_, Vz_, Er_) & + bind(C, name="get_background_profiles_from_balance_") + import :: c_int, c_double + integer(c_int), intent(in) :: dimx_ + real(c_double), intent(out) :: x_(*), q_(*), n_(*), Ti_(*), Te_(*), Vth_(*), Vz_(*), Er_(*) + end subroutine get_background_profiles_from_balance_x + end interface + +contains + + integer(c_int) function count_lines(fname) result(n) + character(len=*), intent(in) :: fname + character(kind=c_char) :: cbuf(len(fname) + 1) + call to_cstr(fname, cbuf) + n = count_lines_in_file_c(cbuf, 0_c_int) + end function count_lines + + subroutine load_data(fname, dim_, ncols, rgrid, qgrid) + character(len=*), intent(in) :: fname + integer(c_int), intent(in) :: dim_, ncols + real(c_double), intent(in) :: rgrid(*) + real(c_double), intent(out) :: qgrid(*) + character(kind=c_char) :: cbuf(len(fname) + 1) + integer(c_int) :: ierr_unused + call to_cstr(fname, cbuf) + ierr_unused = load_data_file_c(cbuf, dim_, ncols, rgrid, qgrid) + end subroutine load_data + + subroutine save_arr(dim_, xgrid, arr, fname) + integer(c_int), intent(in) :: dim_ + real(c_double), intent(in) :: xgrid(*), arr(*) + character(len=*), intent(in) :: fname + character(kind=c_char) :: cbuf(len(fname) + 1) + integer :: ierr_unused + call to_cstr(fname, cbuf) + ierr_unused = save_real_array_c(dim_, xgrid, arr, cbuf) + end subroutine save_arr + + subroutine to_cstr(str, cbuf) + character(len=*), intent(in) :: str + character(kind=c_char), intent(out) :: cbuf(*) + integer :: i, n + n = len_trim(str) + do i = 1, n + cbuf(i) = str(i:i) + end do + cbuf(n + 1) = c_null_char + end subroutine to_cstr + + !> Mirrors background::background(const settings *s): sets up the index + !> table and the output directory. path2project comes from the caller + !> (core.cpp, still C++, has sd->path2project directly). Returns a fixed + !> nonzero sentinel handle for compatibility with core.h's intptr_t bp + !> field and the existing bp_ptr plumbing - the value itself is never + !> read back by anything in this module. + function background_create(path2project_p) result(handle) bind(C, name="background_create_") + type(c_ptr), value :: path2project_p + integer(c_intptr_t) :: handle + character(len=1024) :: path2project + integer(c_int) :: k, ierr_unused + character(len=1024) :: sys_command + external :: set_back_aliases_in_conductivity_parameters + + call read_c_string(path2project_p, path2project) + + ! Fresh-object semantics of the oracle's `new background(...)`: + ! ql-balance re-creates the background every wave-code invocation, + ! so the singleton state must reset on each create. + call reset_state() + + call set_profiles_indices() + + call set_back_aliases_in_conductivity_parameters() + + path2background = trim(path2project)//'background-data/' + + if (get_output_flag_background() > 1) then + sys_command = 'mkdir -p '//trim(path2background) + call execute_command_line(trim(sys_command), exitstat=ierr_unused) + end if + + handle = 1_c_intptr_t + end function background_create + + subroutine reset_state() + if (allocated(profile_names)) deallocate (profile_names) + if (allocated(x)) deallocate (x) + if (allocated(y)) deallocate (y) + if (allocated(Carr)) deallocate (Carr) + if (allocated(Rarr)) deallocate (Rarr) + if (sid /= 0_c_intptr_t) then + call spline_free(sid) + sid = 0_c_intptr_t + end if + end subroutine reset_state + + !> Mirrors background::set_profiles_indices exactly: the k++ assignment + !> order is load-bearing (the oracle's own comment: "DO NOT CHANGE, ONLY + !> ADD NEW IF NEEDED") since every spline channel index downstream + !> depends on it. + subroutine set_profiles_indices() + integer(c_int) :: k, acalc + + acalc = abs(calc_back) + + if (acalc == 1 .or. acalc == 3) then + Nprofiles = 7 + else if (acalc == 2) then + Nprofiles = 11 + else + write (error_unit, '(a)') 'warning: set_profiles_indices: unknown flag!' + stop 1 + end if + + allocate (profile_names(0:Nprofiles - 1)) + + if (acalc == 1 .or. acalc == 3) then + profile_names(0) = 'q'; profile_names(1) = 'n'; profile_names(2) = 'Ti' + profile_names(3) = 'Te'; profile_names(4) = 'Vth'; profile_names(5) = 'Vz' + profile_names(6) = 'Er' + else if (acalc == 2) then + profile_names(0) = 'q'; profile_names(1) = 'n'; profile_names(2) = 'Ti' + profile_names(3) = 'Te'; profile_names(4) = 'Vth'; profile_names(5) = 'Vz' + profile_names(6) = 'Er'; profile_names(7) = 'Bth'; profile_names(8) = 'Bz' + profile_names(9) = 'Jth'; profile_names(10) = 'Jz' + end if + + k = 0 + i_q = k; k = k + 1 + i_n = k; k = k + 1 + i_T(0) = k; k = k + 1 + i_T(1) = k; k = k + 1 + i_Vth(2) = k; k = k + 1 + i_Vz(2) = k; k = k + 1 + i_Er = k; k = k + 1 + i_Bth = k; k = k + 1 + i_Bz = k; k = k + 1 + i_B = k; k = k + 1 + i_hth = k; k = k + 1 + i_hz = k; k = k + 1 + i_dPhi0 = k; k = k + 1 + i_n_p(0) = k; k = k + 1 + i_Vp_p(0) = k; k = k + 1 + i_Vt_p(0) = k; k = k + 1 + i_nu(0) = k; k = k + 1 + i_n_p(1) = k; k = k + 1 + i_Vp_p(1) = k; k = k + 1 + i_Vt_p(1) = k; k = k + 1 + i_nu(1) = k; k = k + 1 + i_J0th(2) = k; k = k + 1 + i_J0z(2) = k; k = k + 1 + i_J0th(1) = k; k = k + 1 + i_J0z(1) = k; k = k + 1 + i_J0th(0) = k; k = k + 1 + i_J0z(0) = k; k = k + 1 + i_Vth(1) = k; k = k + 1 + i_Vz(1) = k; k = k + 1 + i_Vth(0) = k; k = k + 1 + i_Vz(0) = k; k = k + 1 + + dimy = k + end subroutine set_profiles_indices + + subroutine background_set_profiles_from_files() bind(C, name="background_set_profiles_from_files_") + character(len=1024) :: file_name, path2profiles_buf + integer(c_int) :: Nspl, ierr, acalc + + call get_path2profiles(path2profiles_buf) + file_name = trim(path2profiles_buf)//'n.dat' + + dimx = count_lines(file_name) + + Nspl = N + ind_search = int(0.5d0*dimx) + + allocate (x(0:dimx - 1)) + allocate (y(0:dimx*dimy - 1)) + allocate (Carr(0:(Nspl + 1)*dimx*dimy - 1)) + allocate (Rarr(0:(Nspl + 1)*dimy - 1)) + + call spline_alloc(Nspl, 1, dimx, c_loc(x), c_loc(Carr), sid) + + call load_input_background_profiles() + call spline_input_profiles() + + acalc = abs(calc_back) + if (acalc == 1) then + call calculate_equilibrium() + else if (acalc == 2) then + call check_and_spline_equilibrium() + else + write (error_unit, '(a)') & + 'set_background_profiles_from_files: this feature is not implemented yet!' + stop 1 + end if + + flag_dPhi0_calc = 1 + + call find_f0_parameters() + + if (get_output_flag_background() > 1) then + call save_background() + call eval_and_save_f0_moments() + end if + end subroutine background_set_profiles_from_files + + subroutine background_set_profiles_from_interface() & + bind(C, name="background_set_profiles_from_interface_") + integer(c_int) :: Nspl, ierr, acalc, stat_unused + real(dp), allocatable :: q_(:), n_(:), Ti_(:), Te_(:), Vth_(:), Vz_(:), Er_(:) + integer(c_int) :: i + + stat_unused = get_background_dimension_from_balance_c(dimx) + + ind_search = int(0.5d0*dimx) + Nspl = N + + allocate (x(0:dimx - 1)) + allocate (y(0:dimx*dimy - 1)) + allocate (Carr(0:(Nspl + 1)*dimx*dimy - 1)) + allocate (Rarr(0:(Nspl + 1)*dimy - 1)) + + call spline_alloc(Nspl, 1, dimx, c_loc(x), c_loc(Carr), sid) + + allocate (q_(0:dimx - 1), n_(0:dimx - 1), Ti_(0:dimx - 1), Te_(0:dimx - 1)) + allocate (Vth_(0:dimx - 1), Vz_(0:dimx - 1), Er_(0:dimx - 1)) + + call get_background_profiles_from_balance_x(dimx, x, q_, n_, Ti_, Te_, Vth_, Vz_, Er_) + + do i = 0, dimx - 1 + y(i_q*dimx + i) = q_(i) + y(i_n*dimx + i) = n_(i) + y(i_T(0)*dimx + i) = Ti_(i) + y(i_T(1)*dimx + i) = Te_(i) + y(i_Vth(2)*dimx + i) = Vth_(i) + Vz_(i) = Vz_(i) - V_gal_sys + y(i_Vz(2)*dimx + i) = Vz_(i) + y(i_Er*dimx + i) = Er_(i) + end do + + deallocate (q_, n_, Ti_, Te_, Vth_, Vz_, Er_) + + call spline_input_profiles() + + flag_dPhi0_calc = 1 + + acalc = abs(calc_back) + if (acalc == 1) then + call calculate_equilibrium() + else if (acalc == 2) then + write (error_unit, '(a)') & + 'set_background_profiles_from_interface: this feature is not implemented yet!' + stop 1 + else if (acalc == 3) then + flag_dPhi0_calc = 1 + call calculate_equilibrium() + else + write (error_unit, '(a)') & + 'set_background_profiles_from_files: this feature is not implemented yet!' + stop 1 + end if + + call find_f0_parameters() + + if (get_output_flag_background() > 1) then + call save_background() + call eval_and_save_f0_moments() + end if + end subroutine background_set_profiles_from_interface + + subroutine get_path2profiles(buf) + character(len=1024), intent(out) :: buf + interface + subroutine get_background_path2profiles_c(out) bind(C, name="get_background_path2profiles_") + import :: c_char + character(kind=c_char), intent(out) :: out(*) + end subroutine get_background_path2profiles_c + end interface + character(kind=c_char) :: cbuf(1024) + integer :: i + + call get_background_path2profiles_c(cbuf) + buf = '' + do i = 1, 1024 + if (cbuf(i) == c_null_char) exit + buf(i:i) = cbuf(i) + end do + end subroutine get_path2profiles + + !> Mirrors background::load_input_background_profiles: all profiles are + !> assumed to be in the lab frame; Vz is shifted to the moving frame here. + subroutine load_input_background_profiles() + character(len=1024) :: file_name, sys_command, path2profiles_buf + integer(c_int) :: ind(0:10) + integer(c_int) :: i, j + real(dp) :: tmp1, tmp2 + + call get_path2profiles(path2profiles_buf) + + ind = [i_q, i_n, i_T(0), i_T(1), i_Vth(2), i_Vz(2), i_Er, i_Bth, i_Bz, i_J0th(2), i_J0z(2)] + + tmp1 = 0.0d0 + do i = 0, Nprofiles - 1 + file_name = trim(path2profiles_buf)//trim(profile_names(i))//'.dat' + call load_data(file_name, dimx, 1, x, y(ind(i)*dimx:)) + + if (i == 5) then + do j = 0, dimx - 1 + y(ind(i)*dimx + j) = y(ind(i)*dimx + j)*V_scale + y(ind(i)*dimx + j) = y(ind(i)*dimx + j) - V_gal_sys + end do + end if + + tmp2 = 0.0d0 + do j = 0, dimx - 1 + tmp2 = tmp2 + x(j) + end do + if (tmp2 /= tmp1 .and. i /= 0) then + write (output_unit, '(a,es25.16,a,es25.16,a,i0,a)') & + 'warning: load_input_profiles: r grids look different: tmp1=', tmp1, & + ' tmp2=', tmp2, ' i=', i, '!' + end if + tmp1 = tmp2 + + if (get_output_flag_background() > 1) then + sys_command = 'cp '//trim(file_name)//' '//trim(path2background)// & + trim(profile_names(i))//'_i.dat' + call execute_command_line(trim(sys_command)) + end if + end do + + if (x(0) == 0.0d0) then + write (error_unit, '(a)') & + 'warning: load_input_profiles: first point of profiles grid must be not zero!' + end if + end subroutine load_input_background_profiles + + !> Splines the first 7 profiles: q, n, Ti, Te, Vth, Vz (moving frame), Er + !> (lab frame). + subroutine spline_input_profiles() + integer(c_int) :: ierr + call spline_calc(sid, c_loc(y(i_q*dimx:)), i_q, i_Er, c_null_ptr, ierr) + end subroutine spline_input_profiles + + !> ODE right-hand side for the equilibrium u-function (calc_back.cpp's + !> rhs_back): no ctx needed, background is a singleton. + subroutine rhs_back(t, yv, dydt, ctx) + real(dp), intent(in) :: t + real(dp), intent(in) :: yv(:) + real(dp), intent(out) :: dydt(:) + class(*), intent(in), optional :: ctx + real(dp), target :: rloc(1) + real(dp) :: qq, n_, dn, Ti, dTi, Te, dTe, dpress, g + + rloc(1) = t + call spline_eval(sid, 1, c_loc(rloc), 0, 1, i_q, i_T(1), c_loc(Rarr)) + + qq = Rarr(0) + n_ = Rarr(2) + dn = Rarr(3) + Ti = Rarr(4) + dTi = Rarr(5) + Te = Rarr(6) + dTe = Rarr(7) + + dpress = boltz*((Ti + Te)*dn + (dTi + dTe)*n_) + + g = 1.0d0 + t*t/rtor/rtor/qq/qq + + dydt(1) = -2.0d0*t*yv(1)/(qq*qq*g*rtor*rtor) - 8.0d0*pi*dpress + end subroutine rhs_back + + !> Mirrors background::calculate_equilibrium exactly, including the + !> single continuously-carried rk8pd evolve across the whole grid (per + !> the oracle's own comment, splitting this into independent per-segment + !> integrations or changing the tolerances drifts from the recorded + !> golden - do not "clean up" these magic numbers). + subroutine calculate_equilibrium() + integer(c_int), parameter :: Neq = 1 + real(dp) :: rc, g, rcur + real(dp), allocatable :: u(:) + real(dp) :: uval(1) + real(dp), target :: rloc(1) + type(rk8pd_state_t) :: ode_state + type(fortnum_status_t) :: status + integer(c_int) :: nfev, i, ierr + real(dp), pointer :: qarr(:), bth(:), bz(:), b0arr(:), hth(:), hz(:), jth(:), jz(:) + real(dp) :: dbz, dbth + + rc = x(0) + + rloc(1) = rc + call spline_eval(sid, 1, c_loc(rloc), 0, 0, i_q, i_q, c_loc(Rarr)) + + g = 1.0d0 + rc*rc/rtor/rtor/Rarr(0)/Rarr(0) + + allocate (u(0:dimx - 1)) + u(0) = B0*B0*g + uval(1) = u(0) + + call rk8pd_evolve_init(ode_state, Neq, x(1) - rc, status) + if (status%code /= FORTNUM_OK) then + write (error_unit, '(a)') 'calculate_equilibrium: failed to create ODE evolver' + stop 1 + end if + + rcur = rc + nfev = 0 + + do i = 1, dimx - 1 + call rk8pd_evolve_apply(rhs_back, ode_state, rcur, x(i), uval, & + 1.0d-16, 1.0d-16, 100000, nfev, status) + + if (status%code /= FORTNUM_OK) then + write (error_unit, '(a,es12.4,a,i0)') & + 'calculate_equilibrium: ODE solver failed at r = ', rcur, ' (status=', status%code + stop 1 + end if + + u(i) = uval(1) + end do + + if (flag_debug > 1) then + call save_arr(dimx, x, u, trim(path2background)//'u.dat') + end if + + qarr(0:dimx - 1) => y(i_q*dimx:i_q*dimx + dimx - 1) + bth(0:dimx - 1) => y(i_Bth*dimx:i_Bth*dimx + dimx - 1) + bz(0:dimx - 1) => y(i_Bz*dimx:i_Bz*dimx + dimx - 1) + b0arr(0:dimx - 1) => y(i_B*dimx:i_B*dimx + dimx - 1) + + do i = 0, dimx - 1 + bz(i) = sign(1.0d0, B0)*sqrt(u(i)/(1.0d0 + x(i)*x(i)/rtor/rtor/qarr(i)/qarr(i))) + bth(i) = bz(i)*x(i)/qarr(i)/rtor + b0arr(i) = sqrt(bth(i)*bth(i) + bz(i)*bz(i)) + end do + + hth(0:dimx - 1) => y(i_hth*dimx:i_hth*dimx + dimx - 1) + hz(0:dimx - 1) => y(i_hz*dimx:i_hz*dimx + dimx - 1) + + do i = 0, dimx - 1 + hth(i) = bth(i)/b0arr(i) + hz(i) = bz(i)/b0arr(i) + end do + + call spline_calc(sid, c_loc(y(i_Bth*dimx:)), i_Bth, i_hz, c_null_ptr, ierr) + + jth(0:dimx - 1) => y(i_J0th(2)*dimx:i_J0th(2)*dimx + dimx - 1) + jz(0:dimx - 1) => y(i_J0z(2)*dimx:i_J0z(2)*dimx + dimx - 1) + + do i = 0, dimx - 1 + rloc(1) = x(i) + call spline_eval(sid, 1, c_loc(rloc), 1, 1, i_Bth, i_Bz, c_loc(Rarr)) + dbth = Rarr(0) + dbz = Rarr(1) + + jth(i) = -c/4.0d0/pi*dbz + jz(i) = c/4.0d0/pi*(bth(i)/x(i) + dbth) + end do + + call spline_calc(sid, c_loc(y(i_J0th(2)*dimx:)), i_J0th(2), i_J0z(2), c_null_ptr, ierr) + + deallocate (u) + end subroutine calculate_equilibrium + + !> Mirrors background::check_and_spline_equilibrium exactly. + subroutine check_and_spline_equilibrium() + integer(c_int) :: i, ierr + real(dp), pointer :: bth(:), bz(:), b0arr(:), hth(:), hz(:), jth(:) + real(dp) :: dev, Bt, dBt, Bz_, dBz_, p, dpp + real(dp), target :: rloc(1) + + bth(0:dimx - 1) => y(i_Bth*dimx:i_Bth*dimx + dimx - 1) + bz(0:dimx - 1) => y(i_Bz*dimx:i_Bz*dimx + dimx - 1) + b0arr(0:dimx - 1) => y(i_B*dimx:i_B*dimx + dimx - 1) + hth(0:dimx - 1) => y(i_hth*dimx:i_hth*dimx + dimx - 1) + hz(0:dimx - 1) => y(i_hz*dimx:i_hz*dimx + dimx - 1) + + do i = 0, dimx - 1 + b0arr(i) = sqrt(bth(i)*bth(i) + bz(i)*bz(i)) + hth(i) = bth(i)/b0arr(i) + hz(i) = bz(i)/b0arr(i) + end do + + call spline_calc(sid, c_loc(y(i_Bth*dimx:)), i_Bth, i_hz, c_null_ptr, ierr) + call spline_calc(sid, c_loc(y(i_J0th(2)*dimx:)), i_J0th(2), i_J0z(2), c_null_ptr, ierr) + + do i = 0, dimx - 1 + rloc(1) = x(i) + call spline_eval(sid, 1, c_loc(rloc), 0, 1, i_Bth, i_Bth, c_loc(Rarr)) + Bt = Rarr(0); dBt = Rarr(1) + call spline_eval(sid, 1, c_loc(rloc), 0, 1, i_Bz, i_Bz, c_loc(Rarr)) + Bz_ = Rarr(0); dBz_ = Rarr(1) + + call eval_p_dp_local(x(i), Rarr) + p = Rarr(0); dpp = Rarr(1) + + dev = (4.0d0*pi*dpp + Bt*dBt + Bz_*dBz_)/(Bt*Bt/x(i)) + 1.0d0 + + if (abs(dev) > 1.0d-6) then + write (error_unit, '(a,es12.4,a,es12.4)') & + 'warning: check_and_spline_equilibrium: r = ', x(i), ' dev = ', dev + end if + end do + end subroutine check_and_spline_equilibrium + + !> Mirrors background::find_f0_parameters exactly. + subroutine find_f0_parameters() + integer(c_int) :: i, spec, ierr + real(dp), pointer :: n_(:), Ti_(:), Te_(:), Vth_(:), Vz_(:), Er_(:) + real(dp), pointer :: b0_(:), bth_(:), hth_(:), hz_(:), jth_(:), jz_(:), dPhi0(:) + real(dp), pointer :: nui(:), nue(:), n_i_p(:), n_e_p(:) + real(dp), pointer :: Vp_i_p(:), Vp_e_p(:), Vt_i_p(:), Vt_e_p(:) + real(dp) :: Vs_tot, Vp_tot, Js_tot, Jp_tot + real(dp) :: dpress, dn, dTi, dTe, Vsi_, Vse_ + real(dp) :: nuee, nuei, nuie, nuii, Lee, Lei, Lie, Lii + real(dp), parameter :: vf = 1.0d0 + real(dp), target :: rloc(1) + external :: eval_and_set_background_parameters_spec_independent + external :: eval_and_set_background_parameters_spec_dependent + external :: eval_and_set_f0_parameters_nu_and_derivs + external :: dens_par + + n_(0:dimx - 1) => y(i_n*dimx:i_n*dimx + dimx - 1) + Ti_(0:dimx - 1) => y(i_T(0)*dimx:i_T(0)*dimx + dimx - 1) + Te_(0:dimx - 1) => y(i_T(1)*dimx:i_T(1)*dimx + dimx - 1) + Vth_(0:dimx - 1) => y(i_Vth(2)*dimx:i_Vth(2)*dimx + dimx - 1) + Vz_(0:dimx - 1) => y(i_Vz(2)*dimx:i_Vz(2)*dimx + dimx - 1) + Er_(0:dimx - 1) => y(i_Er*dimx:i_Er*dimx + dimx - 1) + + b0_(0:dimx - 1) => y(i_B*dimx:i_B*dimx + dimx - 1) + bth_(0:dimx - 1) => y(i_Bth*dimx:i_Bth*dimx + dimx - 1) + hth_(0:dimx - 1) => y(i_hth*dimx:i_hth*dimx + dimx - 1) + hz_(0:dimx - 1) => y(i_hz*dimx:i_hz*dimx + dimx - 1) + + jth_(0:dimx - 1) => y(i_J0th(2)*dimx:i_J0th(2)*dimx + dimx - 1) + jz_(0:dimx - 1) => y(i_J0z(2)*dimx:i_J0z(2)*dimx + dimx - 1) + + dPhi0(0:dimx - 1) => y(i_dPhi0*dimx:i_dPhi0*dimx + dimx - 1) + + nui(0:dimx - 1) => y(i_nu(0)*dimx:i_nu(0)*dimx + dimx - 1) + nue(0:dimx - 1) => y(i_nu(1)*dimx:i_nu(1)*dimx + dimx - 1) + + n_i_p(0:dimx - 1) => y(i_n_p(0)*dimx:i_n_p(0)*dimx + dimx - 1) + n_e_p(0:dimx - 1) => y(i_n_p(1)*dimx:i_n_p(1)*dimx + dimx - 1) + + Vp_i_p(0:dimx - 1) => y(i_Vp_p(0)*dimx:i_Vp_p(0)*dimx + dimx - 1) + Vp_e_p(0:dimx - 1) => y(i_Vp_p(1)*dimx:i_Vp_p(1)*dimx + dimx - 1) + + Vt_i_p(0:dimx - 1) => y(i_Vt_p(0)*dimx:i_Vt_p(0)*dimx + dimx - 1) + Vt_e_p(0:dimx - 1) => y(i_Vt_p(1)*dimx:i_Vt_p(1)*dimx + dimx - 1) + + do i = 0, dimx - 1 + Lee = 23.5d0 - log(sqrt(n_(i))/Te_(i)**1.25d0) - (log(Te_(i)) - 2.0d0)/4.0d0 + Lei = 30.0d0 - log(sqrt(n_(i))/Ti_(i)**1.5d0*(charge(0)/e)**2/(mass(0)/mp)) + Lie = Lei + Lii = 23.0d0 - log((charge(0)/e)**3/Ti_(i)**1.5d0*sqrt(2.0d0*n_(i))) + + nuee = (5.8d-6)*n_(i)*Lee/sqrt(Te_(i))/(vf*Te_(i)) + nuei = (7.7d-6)*n_(i)*Lei*(charge(0)/e)**2/(vf*Te_(i))**1.5d0 + nuie = (3.2d-9)*n_(i)*Lie*(charge(0)/e)**2/(mass(0)/mp)/sqrt(Te_(i))/(vf*Ti_(i)) + nuii = (1.4d-7)*n_(i)*Lii*(charge(0)/e)**4/sqrt(mass(0)/mp)/sqrt(Ti_(i))/(vf*Ti_(i)) + + nui(i) = zion*(nuie + nuii + 10.0d0) + nue(i) = zele*(nuee + nuei + 10.0d0) + + n_i_p(i) = n_(i) + n_e_p(i) = n_(i) + + Vt_i_p(i) = sqrt(boltz*Ti_(i)/mass(0)) + Vt_e_p(i) = sqrt(boltz*Te_(i)/mass(1)) + + Vp_tot = hth_(i)*Vth_(i) + hz_(i)*Vz_(i) + Jp_tot = hth_(i)*jth_(i) + hz_(i)*jz_(i) + + Vp_i_p(i) = Vp_tot + Jp_tot*mass(1)/mass(0)/e/n_(i)/(1.0d0 + mass(1)/mass(0)) + Vp_e_p(i) = Vp_tot - Jp_tot/e/n_(i)/(1.0d0 + mass(1)/mass(0)) + + if (flag_dPhi0_calc > 0) then + Vs_tot = hz_(i)*Vth_(i) - hth_(i)*Vz_(i) + Js_tot = hz_(i)*jth_(i) - hth_(i)*jz_(i) + + Vsi_ = Vs_tot + Js_tot*mass(1)/mass(0)/e/n_(i)/(1.0d0 + mass(1)/mass(0)) + Vse_ = Vs_tot - Js_tot/e/n_(i)/(1.0d0 + mass(1)/mass(0)) + + rloc(1) = x(i) + call spline_eval(sid, 1, c_loc(rloc), 1, 1, i_n, i_T(1), c_loc(Rarr)) + dn = Rarr(0); dTi = Rarr(1); dTe = Rarr(2) + + dpress = boltz*(Ti_(i)*dn + dTi*n_(i)) + dPhi0(i) = Vsi_/c*b0_(i) - dpress/charge(0)/n_(i) + else + dPhi0(i) = -Er_(i) + bth_(i)*V_gal_sys/c + end if + end do + + call spline_calc(sid, c_loc(y(i_dPhi0*dimx:)), i_dPhi0, i_nu(1), c_null_ptr, ierr) + + do i = 0, dimx - 1 + call eval_and_set_background_parameters_spec_independent(x(i), flag_back) + + do spec = 0, 1 + call eval_and_set_background_parameters_spec_dependent(x(i), spec, flag_back) + call eval_and_set_f0_parameters_nu_and_derivs(x(i), spec, flag_back) + call dens_par(n_(i), y(i_n_p(spec)*dimx + i)) + end do + end do + + call spline_calc(sid, c_loc(y(i_n_p(0)*dimx:)), i_n_p(0), i_n_p(0), c_null_ptr, ierr) + call spline_calc(sid, c_loc(y(i_n_p(1)*dimx:)), i_n_p(1), i_n_p(1), c_null_ptr, ierr) + end subroutine find_f0_parameters + + !> Mirrors background::eval_and_save_f0_moments (debug dump, gated + !> behind the RUNTIME flag get_output_flag_background_()>1, not a + !> compile-time DEBUG_FLAG - keep computing it). + subroutine eval_and_save_f0_moments() + integer(c_int), parameter :: num_moms = 16 + integer(c_int) :: u_(0:num_moms - 1) + character(len=8) :: moms_name(0:num_moms - 1) + character(len=1024) :: full_name + integer(c_int) :: i, k, spec + real(dp) :: n_m(0:1), Vth_m(0:2), Vz_m(0:2), Vs_m(0:2), Vs_0_m(0:2), Vp_m(0:2), T_m(0:1) + real(dp) :: j0th_m(0:2), j0z_m(0:2), j0s_m(0:2), j0p_m(0:2) + external :: eval_and_set_background_parameters_spec_independent + external :: eval_and_set_background_parameters_spec_dependent + external :: eval_and_set_f0_parameters_nu_and_derivs + external :: dens_mom, vth_mom, vz_mom, vs_mom, vp_mom, eterm_mom + + moms_name = ['ni_m ', 'ne_m ', 'Vth_m ', 'Vz_m ', & + 'Vsi_m ', 'Vse_m ', 'Vpi_m ', 'Vpe_m ', & + 'Vs0i_m ', 'Vs0e_m ', 'Ti_m ', 'Te_m ', & + 'j0s_m ', 'j0p_m ', 'j0th_m ', 'j0z_m '] + + do k = 0, num_moms - 1 + full_name = trim(path2background)//trim(moms_name(k))//'.dat' + open (newunit=u_(k), file=trim(full_name), status='replace', action='write') + end do + + do i = 0, dimx - 1 + call eval_and_set_background_parameters_spec_independent(x(i), flag_back) + + do spec = 0, 1 + call eval_and_set_background_parameters_spec_dependent(x(i), spec, flag_back) + call eval_and_set_f0_parameters_nu_and_derivs(x(i), spec, flag_back) + + call dens_mom(n_m(spec)) + call vth_mom(Vth_m(spec)) + Vth_m(spec) = Vth_m(spec)*x(i) + call vz_mom(Vz_m(spec)) + call vs_mom(Vs_m(spec)) + call vs_0(x(i), spec, Vs_0_m(spec)) + call vp_mom(Vp_m(spec)) + call eterm_mom(T_m(spec)) + T_m(spec) = 2.0d0*T_m(spec)/3.0d0/n_m(spec) + end do + + Vth_m(2) = (mass(0)*Vth_m(0) + mass(1)*Vth_m(1))/(mass(0) + mass(1)) + Vz_m(2) = (mass(0)*Vz_m(0) + mass(1)*Vz_m(1))/(mass(0) + mass(1)) + + j0p_m(2) = e*(Vp_m(0) - Vp_m(1)) + j0s_m(2) = e*(Vs_m(0) - Vs_m(1)) + j0th_m(2) = e*(Vth_m(0) - Vth_m(1)) + j0z_m(2) = e*(Vz_m(0) - Vz_m(1)) + + write (u_(0), '(es24.15,1x,es24.15)') x(i), n_m(0) + write (u_(1), '(es24.15,1x,es24.15)') x(i), n_m(1) + write (u_(2), '(es24.15,1x,es24.15)') x(i), Vth_m(2)/n_m(0) + write (u_(3), '(es24.15,1x,es24.15)') x(i), Vz_m(2)/n_m(0) + write (u_(4), '(es24.15,1x,es24.15)') x(i), Vs_m(0)/n_m(0) + write (u_(5), '(es24.15,1x,es24.15)') x(i), Vs_m(1)/n_m(1) + write (u_(6), '(es24.15,1x,es24.15)') x(i), Vp_m(0)/n_m(0) + write (u_(7), '(es24.15,1x,es24.15)') x(i), Vp_m(1)/n_m(1) + write (u_(8), '(es24.15,1x,es24.15)') x(i), Vs_0_m(0) + write (u_(9), '(es24.15,1x,es24.15)') x(i), Vs_0_m(1) + write (u_(10), '(es24.15,1x,es24.15)') x(i), T_m(0) + write (u_(11), '(es24.15,1x,es24.15)') x(i), T_m(1) + write (u_(12), '(es24.15,1x,es24.15)') x(i), j0s_m(2) + write (u_(13), '(es24.15,1x,es24.15)') x(i), j0p_m(2) + write (u_(14), '(es24.15,1x,es24.15)') x(i), j0th_m(2) + write (u_(15), '(es24.15,1x,es24.15)') x(i), j0z_m(2) + end do + + do k = 0, num_moms - 1 + close (u_(k)) + end do + end subroutine eval_and_save_f0_moments + + subroutine save_background() + call save_arr(dimx, x, y(i_Bth*dimx:), trim(path2background)//'b0th.dat') + call save_arr(dimx, x, y(i_Bz*dimx:), trim(path2background)//'b0z.dat') + call save_arr(dimx, x, y(i_B*dimx:), trim(path2background)//'b0.dat') + call save_arr(dimx, x, y(i_hth*dimx:), trim(path2background)//'hth.dat') + call save_arr(dimx, x, y(i_hz*dimx:), trim(path2background)//'hz.dat') + call save_arr(dimx, x, y(i_J0th(2)*dimx:), trim(path2background)//'j0th.dat') + call save_arr(dimx, x, y(i_J0z(2)*dimx:), trim(path2background)//'j0z.dat') + call save_arr(dimx, x, y(i_nu(0)*dimx:), trim(path2background)//'nui.dat') + call save_arr(dimx, x, y(i_nu(1)*dimx:), trim(path2background)//'nue.dat') + call save_arr(dimx, x, y(i_dPhi0*dimx:), trim(path2background)//'dPhi0.dat') + call save_arr(dimx, x, y(i_n_p(0)*dimx:), trim(path2background)//'ni_p.dat') + call save_arr(dimx, x, y(i_n_p(1)*dimx:), trim(path2background)//'ne_p.dat') + call save_arr(dimx, x, y(i_Vp_p(0)*dimx:), trim(path2background)//'Vpi_p.dat') + call save_arr(dimx, x, y(i_Vp_p(1)*dimx:), trim(path2background)//'Vpe_p.dat') + call save_arr(dimx, x, y(i_Vt_p(0)*dimx:), trim(path2background)//'Vti_p.dat') + call save_arr(dimx, x, y(i_Vt_p(1)*dimx:), trim(path2background)//'Vte_p.dat') + end subroutine save_background + + subroutine interp_basic_background_profiles(r, qq, n_, Ti, Te, Vth, Vz, dPhi0v) + real(dp), intent(in) :: r + real(dp), intent(out) :: qq, n_, Ti, Te, Vth, Vz, dPhi0v + real(dp), target :: rloc(1) + rloc(1) = r + call spline_eval(sid, 1, c_loc(rloc), 0, 0, i_q, i_Vz(2), c_loc(Rarr)) + qq = Rarr(0); n_ = Rarr(1); Ti = Rarr(2); Te = Rarr(3); Vth = Rarr(4); Vz = Rarr(5) + call spline_eval(sid, 1, c_loc(rloc), 0, 0, i_dPhi0, i_dPhi0, c_loc(Rarr)) + dPhi0v = Rarr(0) + end subroutine interp_basic_background_profiles + + subroutine transform_basic_background_profiles_to_lab_frame(r, Vz, dPhi0v) + real(dp), intent(in) :: r + real(dp), intent(inout) :: Vz, dPhi0v + real(dp) :: Bth + real(dp), target :: rloc(1) + rloc(1) = r + call spline_eval(sid, 1, c_loc(rloc), 0, 0, i_Bth, i_Bth, c_loc(Rarr)) + Bth = Rarr(0) + Vz = Vz + V_gal_sys + dPhi0v = dPhi0v - Bth*V_gal_sys/c + end subroutine transform_basic_background_profiles_to_lab_frame + + subroutine background_interp_in_lab_frame(dim_, rv, qq, n_, Ti, Te, Vth, Vz, dPhi0v) & + bind(C, name="interp_basic_background_profiles_in_lab_frame_") + integer(c_int), value :: dim_ + real(c_double), intent(in) :: rv(0:dim_ - 1) + real(c_double), intent(out) :: qq(0:dim_ - 1), n_(0:dim_ - 1), Ti(0:dim_ - 1), Te(0:dim_ - 1) + real(c_double), intent(inout) :: Vth(0:dim_ - 1), Vz(0:dim_ - 1), dPhi0v(0:dim_ - 1) + integer(c_int) :: i + do i = 0, dim_ - 1 + call interp_basic_background_profiles(rv(i), qq(i), n_(i), Ti(i), Te(i), Vth(i), Vz(i), dPhi0v(i)) + call transform_basic_background_profiles_to_lab_frame(rv(i), Vz(i), dPhi0v(i)) + end do + end subroutine background_interp_in_lab_frame + + real(c_double) function get_background_x0() bind(C, name="get_background_x0_") + get_background_x0 = x(0) + end function get_background_x0 + + real(c_double) function get_background_xlast() bind(C, name="get_background_xlast_") + get_background_xlast = x(dimx - 1) + end function get_background_xlast + + integer(c_int) function get_background_dimx() bind(C, name="get_background_dimx_") + get_background_dimx = dimx + end function get_background_dimx + + !================================================================== + ! eval_back.cpp live functions. + ! + ! Two distinct calling conventions, matching the oracle exactly: + ! - eval_background_spec_independent_/eval_f0_parameters_nu_and_derivs_ + ! (trailing underscore) are called ONLY from the pre-existing, + ! unchanged Fortran conduct_parameters.f90 via an implicit interface + ! (F77-style), so every argument is BY REFERENCE - matching the + ! oracle's `double *r`/`int *spec`/`background **bpro` pointer args. + ! The handle argument is accepted for ABI compatibility (so + ! conduct_parameters.f90 needs zero edits) but never read, since + ! background is a singleton. + ! - eval_hthz/eval_Bt_dBt_Bz_dBz/eval_p_dp/eval_mass_density/eval_Bt_Bz/ + ! eval_Bt/eval_Bz/eval_Vt/eval_Vz/eval_B0_ht_hz_n0_Vz are called from + ! still-C++ files (imhd/compressible_flow.cpp, imhd/incompressible.cpp, + ! imhd/imhd_zone.cpp, flre/flre_zone.cpp, mode/transforms.cpp) as + ! ordinary C++ function calls, so r/bp are BY VALUE (matching the + ! oracle's plain `double r, const background *bp` signatures) - bp + ! is accepted (background.h now forward-declares `class background;` + ! with no body, so these C++ files keep compiling unchanged, passing + ! around an opaque, never-dereferenced pointer value) but never read. + ! eval_hthz_ (trailing underscore) is the BY-REFERENCE sibling of + ! eval_hthz, called only from this port's own flre_quants_m.f90. + !================================================================== + + subroutine eval_background_spec_independent(rval, handle, Rout) & + bind(C, name="eval_background_spec_independent_") + real(c_double), intent(in) :: rval + integer(c_intptr_t), intent(in) :: handle + real(c_double), intent(out), target :: Rout(*) + real(dp), target :: rloc(1) + rloc(1) = rval + call spline_eval(sid, 1, c_loc(rloc), 0, 2, i_B, i_dPhi0, c_loc(Rout)) + end subroutine eval_background_spec_independent + + subroutine eval_f0_parameters_nu_and_derivs(rval, spec, handle, Rout) & + bind(C, name="eval_f0_parameters_nu_and_derivs_") + real(c_double), intent(in) :: rval + integer(c_int), intent(in) :: spec + integer(c_intptr_t), intent(in) :: handle + real(c_double), intent(out), target :: Rout(*) + real(dp), target :: rloc(1) + rloc(1) = rval + call spline_eval(sid, 1, c_loc(rloc), 0, 2, i_n_p(spec), i_nu(spec), c_loc(Rout)) + end subroutine eval_f0_parameters_nu_and_derivs + + !> Internal helper, called from eval_and_save_f0_moments and (via the + !> bind(C) sibling vs_0_f below) gcorr.f90's still-live + !> eval_and_set_params_for_additional_current_ - a genuine miss in an + !> earlier "0 callers" grep pass (which only checked C++ files; gcorr.f90 + !> is Fortran), caught only by the link step. Re-confirms: always check + !> Fortran (.f90) callers too, not just C++ ones, before calling + !> something dead. + subroutine vs_0(r, spec, res) + real(dp), intent(in) :: r + integer(c_int), intent(in) :: spec + real(dp), intent(out) :: res + real(dp), target :: rloc(1) + real(dp) :: n_, dn, T, dT, dpress, Bv, dPhi0v + + rloc(1) = r + call spline_eval(sid, 1, c_loc(rloc), 0, 1, i_n, i_n, c_loc(Rarr)) + n_ = Rarr(0); dn = Rarr(1) + call spline_eval(sid, 1, c_loc(rloc), 0, 1, i_T(spec), i_T(spec), c_loc(Rarr)) + T = Rarr(0); dT = Rarr(1) + + dpress = boltz*(dn*T + n_*dT) + + call spline_eval(sid, 1, c_loc(rloc), 0, 0, i_B, i_B, c_loc(Rarr)) + Bv = Rarr(0) + call spline_eval(sid, 1, c_loc(rloc), 0, 0, i_dPhi0, i_dPhi0, c_loc(Rarr)) + dPhi0v = Rarr(0) + + res = c/Bv*(dPhi0v + dpress/charge(spec)/n_) + end subroutine vs_0 + + !> bind(C) replacement for vs_0_f_, called via bp_ptr from gcorr.f90 - + !> same by-reference convention as eval_background_spec_independent_. + subroutine vs_0_f(rval, spec, handle, res) bind(C, name="vs_0_f_") + real(c_double), intent(in) :: rval + integer(c_int), intent(in) :: spec + integer(c_intptr_t), intent(in) :: handle + real(c_double), intent(out) :: res + real(dp) :: res_local + call vs_0(rval, spec, res_local) + res = res_local + end subroutine vs_0_f + + subroutine eval_hthz_c(rval, omin, omax, bp, hout) bind(C, name="eval_hthz_") + real(c_double), intent(in) :: rval + integer(c_int), intent(in) :: omin, omax + integer(c_intptr_t), intent(in) :: bp + real(c_double), intent(out), target :: hout(*) + real(dp), target :: rloc(1) + rloc(1) = rval + call spline_eval(sid, 1, c_loc(rloc), omin, omax, i_hth, i_hz, c_loc(hout)) + end subroutine eval_hthz_c + + subroutine eval_hthz(rval, omin, omax, bp, hout) bind(C, name="eval_hthz") + real(c_double), value :: rval + integer(c_int), value :: omin, omax + type(c_ptr), value :: bp + real(c_double), intent(out), target :: hout(*) + real(dp), target :: rloc(1) + rloc(1) = rval + call spline_eval(sid, 1, c_loc(rloc), omin, omax, i_hth, i_hz, c_loc(hout)) + end subroutine eval_hthz + + subroutine eval_Bt_dBt_Bz_dBz(rval, bp, R) bind(C, name="eval_Bt_dBt_Bz_dBz") + real(c_double), value :: rval + type(c_ptr), value :: bp + real(c_double), intent(out), target :: R(*) + real(dp), target :: rloc(1) + rloc(1) = rval + call spline_eval(sid, 1, c_loc(rloc), 0, 1, i_Bth, i_Bz, c_loc(R)) + end subroutine eval_Bt_dBt_Bz_dBz + + subroutine eval_p_dp(rval, bp, R) bind(C, name="eval_p_dp") + real(c_double), value :: rval + type(c_ptr), value :: bp + real(c_double), intent(out), target :: R(*) + real(dp), target :: rloc(1) + rloc(1) = rval + call eval_p_dp_local(rloc(1), R) + end subroutine eval_p_dp + + !> Shared by eval_p_dp (external C++ callers) and + !> check_and_spline_equilibrium (internal use). + subroutine eval_p_dp_local(r, Rout) + real(dp), intent(in) :: r + real(dp), intent(out) :: Rout(0:1) + real(dp), target :: S(0:3) + real(dp) :: n_, dn, Ti, dTi, Te, dTe + real(dp), target :: rloc(1) + rloc(1) = r + call spline_eval(sid, 1, c_loc(rloc), 0, 1, i_n, i_n, c_loc(S)) + n_ = S(0); dn = S(1) + call spline_eval(sid, 1, c_loc(rloc), 0, 1, i_T(0), i_T(1), c_loc(S)) + Ti = S(0); dTi = S(1); Te = S(2); dTe = S(3) + Rout(0) = boltz*(n_*(Ti + Te)) + Rout(1) = boltz*(dn*(Ti + Te) + n_*(dTi + dTe)) + end subroutine eval_p_dp_local + + subroutine eval_mass_density(rval, bp, R) bind(C, name="eval_mass_density") + real(c_double), value :: rval + type(c_ptr), value :: bp + real(c_double), intent(out), target :: R(*) + real(dp), target :: rloc(1) + rloc(1) = rval + call spline_eval(sid, 1, c_loc(rloc), 0, 0, i_n, i_n, c_loc(R)) + R(1) = R(1)*mass(0) + end subroutine eval_mass_density + + subroutine eval_Bt_Bz(rval, bp, R) bind(C, name="eval_Bt_Bz") + real(c_double), value :: rval + type(c_ptr), value :: bp + real(c_double), intent(out), target :: R(*) + real(dp), target :: rloc(1) + rloc(1) = rval + call spline_eval(sid, 1, c_loc(rloc), 0, 0, i_Bth, i_Bz, c_loc(R)) + end subroutine eval_Bt_Bz + + subroutine eval_Bt(rval, bp, R) bind(C, name="eval_Bt") + real(c_double), value :: rval + type(c_ptr), value :: bp + real(c_double), intent(out), target :: R(*) + real(dp), target :: rloc(1) + rloc(1) = rval + call spline_eval(sid, 1, c_loc(rloc), 0, 0, i_Bth, i_Bth, c_loc(R)) + end subroutine eval_Bt + + subroutine eval_Bz(rval, bp, R) bind(C, name="eval_Bz") + real(c_double), value :: rval + type(c_ptr), value :: bp + real(c_double), intent(out), target :: R(*) + real(dp), target :: rloc(1) + rloc(1) = rval + call spline_eval(sid, 1, c_loc(rloc), 0, 0, i_Bz, i_Bz, c_loc(R)) + end subroutine eval_Bz + + subroutine eval_Vt(rval, bp, R) bind(C, name="eval_Vt") + real(c_double), value :: rval + type(c_ptr), value :: bp + real(c_double), intent(out), target :: R(*) + real(dp), target :: rloc(1) + rloc(1) = rval + call spline_eval(sid, 1, c_loc(rloc), 0, 0, i_Vth(2), i_Vth(2), c_loc(R)) + end subroutine eval_Vt + + subroutine eval_Vz(rval, bp, R) bind(C, name="eval_Vz") + real(c_double), value :: rval + type(c_ptr), value :: bp + real(c_double), intent(out), target :: R(*) + real(dp), target :: rloc(1) + rloc(1) = rval + call spline_eval(sid, 1, c_loc(rloc), 0, 0, i_Vz(2), i_Vz(2), c_loc(R)) + end subroutine eval_Vz + + subroutine eval_B0_ht_hz_n0_Vz(rval, bp, R) bind(C, name="eval_B0_ht_hz_n0_Vz") + real(c_double), value :: rval + type(c_ptr), value :: bp + real(c_double), intent(out), target :: R(0:4) + real(dp), target :: rloc(1) + rloc(1) = rval + call spline_eval(sid, 1, c_loc(rloc), 0, 0, i_B, i_hz, c_loc(R(0:2))) + call spline_eval(sid, 1, c_loc(rloc), 0, 0, i_n, i_n, c_loc(R(3:3))) + call spline_eval(sid, 1, c_loc(rloc), 0, 0, i_Vz(2), i_Vz(2), c_loc(R(4:4))) + end subroutine eval_B0_ht_hz_n0_Vz + + !> Live (confirmed via calc_mode.cpp:30,41,70 - missed in an earlier + !> "0 callers" grep pass because the call sites have no space before + !> the opening paren, q(x,...), which the original pattern match + !> assumed; always re-verify a "dead" claim by reading consumer code, + !> not just trusting one grep pattern). + !> Matches wave_code_interface.cpp's get_background_magnetic_fields_ + !> from_wave_code_ inline spline_eval_ (i_Bth..i_B, 3 consecutive + !> channels) and get_collision_frequences_from_wave_code_'s two + !> single-channel calls (i_nu(0), i_nu(1) - NOT consecutive in the + !> index table, so two separate evaluations). + subroutine get_background_magnetic_fields(rval, Bt, Bz, B0) & + bind(C, name="get_background_magnetic_fields_") + real(c_double), value :: rval + real(c_double), intent(out), target :: Bt(1), Bz(1), B0(1) + real(dp), target :: rloc(1), Rl(0:2) + rloc(1) = rval + call spline_eval(sid, 1, c_loc(rloc), 0, 0, i_Bth, i_B, c_loc(Rl)) + Bt(1) = Rl(0); Bz(1) = Rl(1); B0(1) = Rl(2) + end subroutine get_background_magnetic_fields + + subroutine get_background_collision_freqs(rval, nui, nue) & + bind(C, name="get_background_collision_freqs_") + real(c_double), value :: rval + real(c_double), intent(out), target :: nui(1), nue(1) + real(dp), target :: rloc(1) + rloc(1) = rval + call spline_eval(sid, 1, c_loc(rloc), 0, 0, i_nu(0), i_nu(0), c_loc(nui)) + call spline_eval(sid, 1, c_loc(rloc), 0, 0, i_nu(1), i_nu(1), c_loc(nue)) + end subroutine get_background_collision_freqs + + real(c_double) function eval_q(rval, bp) bind(C, name="q") + real(c_double), value :: rval + type(c_ptr), value :: bp + real(dp), target :: rloc(1), ans(1) + rloc(1) = rval + call spline_eval(sid, 1, c_loc(rloc), 0, 0, i_q, i_q, c_loc(ans)) + eval_q = ans(1) + end function eval_q + + subroutine read_c_string(cp_, out) + type(c_ptr), value :: cp_ + character(len=*), intent(out) :: out + character(kind=c_char), pointer :: chars(:) + integer :: i + + call c_f_pointer(cp_, chars, [len(out)]) + out = '' + do i = 1, len(out) + if (chars(i) == c_null_char) exit + out(i:i) = chars(i) + end do + end subroutine read_c_string + +end module kilca_background_data_m diff --git a/KiLCA/background/background_m.f90 b/KiLCA/background/background_m.f90 index 29477620..54362998 100644 --- a/KiLCA/background/background_m.f90 +++ b/KiLCA/background/background_m.f90 @@ -28,29 +28,214 @@ module background !Other misc parameters: real (dp) :: huge_factor; +integer :: calc_back; !flag selecting the background calculation method +integer :: N; !spline degree for background profiles +character (len=1024) :: path2profiles; !directory holding the profile .dat files + end module !------------------------------------------------------------------------------ -subroutine copy_background_data_to_background_module (bp) - -use constants, only: pp; -use background; - -implicit none; - -integer(pp), intent(in) :: bp; - -call set_background_settings_c (bp, rtor, rp, B0, flag_back, V_gal_sys, V_scale, zele, zion, flag_debug); - -call set_particles_settings_c (bp, mass, charge); +!> Read background.in into the background module, replacing the former C++ +!> back_sett::read_settings. Layout: header, rtor/rp/B0, skip, header, +!> path2profiles, calc_back, flag_back, N, V_gal_sys, V_scale, m_i, zele, zion, +!> skip, header, flag_debug, skip; then mass/charge/huge_factor are derived +!> exactly as the C++ constructor did. +subroutine read_background_settings(path) bind(C, name="read_background_settings_") + +use, intrinsic :: iso_c_binding, only: c_char, c_null_char +use, intrinsic :: iso_fortran_env, only: error_unit +use constants, only: mp, e +use background + +character(kind=c_char), dimension(*), intent(in) :: path + +character(len=1024) :: fpath, fname, line, before +real(dp) :: m_i +integer :: i, u, ios +!> C++ constants.h m_e literal (2 ULP off the Fortran constants module's +!> me = mp/1836.15...); the golden record encodes the C++ value on every +!> ported electron-parameter path (omc_, vT_). +real(dp), parameter :: m_e_cpp = 9.10938185917485d-28 + +fpath = '' +i = 1 +do + if (path(i) == c_null_char .or. i > 1024) exit + fpath(i:i) = path(i) + i = i + 1 +end do + +fname = trim(fpath)//'/background.in' +open (newunit=u, file=trim(fname), status='old', action='read', iostat=ios) +if (ios /= 0) then + write (error_unit, '(a,a)') "error: read_background_settings: cannot open ", trim(fname) + error stop +end if -call set_huge_factor_c (bp, huge_factor); +call skip(u) +call value_before_hash(u, before); read (before, *) rtor +call value_before_hash(u, before); read (before, *) rp +call value_before_hash(u, before); read (before, *) B0 +call skip(u) + +call skip(u) +call value_before_hash(u, before); path2profiles = trim(adjustl(before)) +call value_before_hash(u, before); read (before, *) calc_back +call value_before_hash(u, before); flag_back = trim(adjustl(before)) +call value_before_hash(u, before); read (before, *) N +call value_before_hash(u, before); read (before, *) V_gal_sys +call value_before_hash(u, before); read (before, *) V_scale +call value_before_hash(u, before); read (before, *) m_i +call value_before_hash(u, before); read (before, *) zele +call value_before_hash(u, before); read (before, *) zion +call skip(u) + +call skip(u) +call value_before_hash(u, before); read (before, *) flag_debug +call skip(u) + +close (u) + +mass(0) = m_i*mp +mass(1) = m_e_cpp +charge(0) = e +charge(1) = -e +huge_factor = 1.0d20 + +if (flag_debug > 0) call print_background_module_data() + +contains + + subroutine skip(unit) + integer, intent(in) :: unit + integer :: jos + read (unit, '(a)', iostat=jos) line + if (jos /= 0) then + write (error_unit, '(a)') "error: read_background_settings: read error" + error stop + end if + end subroutine skip + + subroutine value_before_hash(unit, out) + integer, intent(in) :: unit + character(len=*), intent(out) :: out + character(len=1024) :: buf + integer :: pos, jos + read (unit, '(a)', iostat=jos) buf + if (jos /= 0) then + write (error_unit, '(a)') "error: read_background_settings: read error" + error stop + end if + pos = index(buf, '#') + if (pos > 0) then + out = buf(1:pos - 1) + else + out = buf + end if + end subroutine value_before_hash + +end subroutine read_background_settings -if (flag_debug > 0) then - call print_background_module_data (); -end if +!------------------------------------------------------------------------------ +real(c_double) function get_background_rtor() bind(C, name="get_background_rtor_") + use, intrinsic :: iso_c_binding, only: c_double + use background, only: rtor + get_background_rtor = rtor +end function + +real(c_double) function get_background_rp() bind(C, name="get_background_rp_") + use, intrinsic :: iso_c_binding, only: c_double + use background, only: rp + get_background_rp = rp +end function + +real(c_double) function get_background_B0() bind(C, name="get_background_B0_") + use, intrinsic :: iso_c_binding, only: c_double + use background, only: B0 + get_background_B0 = B0 +end function + +real(c_double) function get_background_V_gal_sys() bind(C, name="get_background_V_gal_sys_") + use, intrinsic :: iso_c_binding, only: c_double + use background, only: V_gal_sys + get_background_V_gal_sys = V_gal_sys +end function + +real(c_double) function get_background_V_scale() bind(C, name="get_background_V_scale_") + use, intrinsic :: iso_c_binding, only: c_double + use background, only: V_scale + get_background_V_scale = V_scale +end function + +real(c_double) function get_background_zele() bind(C, name="get_background_zele_") + use, intrinsic :: iso_c_binding, only: c_double + use background, only: zele + get_background_zele = zele +end function + +real(c_double) function get_background_zion() bind(C, name="get_background_zion_") + use, intrinsic :: iso_c_binding, only: c_double + use background, only: zion + get_background_zion = zion +end function + +integer(c_int) function get_background_flag_debug() bind(C, name="get_background_flag_debug_") + use, intrinsic :: iso_c_binding, only: c_int + use background, only: flag_debug + get_background_flag_debug = flag_debug +end function + +real(c_double) function get_background_huge_factor() bind(C, name="get_background_huge_factor_") + use, intrinsic :: iso_c_binding, only: c_double + use background, only: huge_factor + get_background_huge_factor = huge_factor +end function + +integer(c_int) function get_background_calc_back() bind(C, name="get_background_calc_back_") + use, intrinsic :: iso_c_binding, only: c_int + use background, only: calc_back + get_background_calc_back = calc_back +end function + +integer(c_int) function get_background_N() bind(C, name="get_background_N_") + use, intrinsic :: iso_c_binding, only: c_int + use background, only: N + get_background_N = N +end function + +real(c_double) function get_background_mass(i) bind(C, name="get_background_mass_") + use, intrinsic :: iso_c_binding, only: c_int, c_double + use background, only: mass + integer(c_int), value :: i + get_background_mass = mass(i) +end function + +real(c_double) function get_background_charge(i) bind(C, name="get_background_charge_") + use, intrinsic :: iso_c_binding, only: c_int, c_double + use background, only: charge + integer(c_int), value :: i + get_background_charge = charge(i) +end function + +function get_background_flag_back() result(ch) bind(C, name="get_background_flag_back_") + use, intrinsic :: iso_c_binding, only: c_char + use background, only: flag_back + character(kind=c_char) :: ch + ch = flag_back(1:1) +end function + +subroutine get_background_path2profiles(out) bind(C, name="get_background_path2profiles_") + use, intrinsic :: iso_c_binding, only: c_char, c_null_char + use background, only: path2profiles + character(kind=c_char), dimension(*), intent(out) :: out + integer :: i, n + n = len_trim(path2profiles) + do i = 1, n + out(i) = path2profiles(i:i) + end do + out(n + 1) = c_null_char end subroutine !-------------------------------------------------------------------- diff --git a/KiLCA/background/calc_back.cpp b/KiLCA/background/calc_back.cpp deleted file mode 100644 index d2c9e45b..00000000 --- a/KiLCA/background/calc_back.cpp +++ /dev/null @@ -1,599 +0,0 @@ -/*! \file calc_back.cpp - \brief The functions used to calculate equilibrium background profiles in cylindrical geometry. -*/ - -#include -#include -#include -#include -#include -#include - -#include "fortnum.h" - -#include "shared.h" -#include "settings.h" -#include "background.h" -#include "spline.h" -#include "inout.h" -#include "calc_back.h" -#include "eval_back.h" -#include "constants.h" -#include "conduct_parameters.h" - -// GSL returned 0 (GSL_SUCCESS) from rhs/jac callbacks; keep the value so the -// callback contracts and the historical control flow stay byte-identical. -#ifndef GSL_SUCCESS -#define GSL_SUCCESS 0 -#endif - -/*-----------------------------------------------------------------*/ - -int rhs_back (double r, const double y[], double dy[], void * params) -{ -background * bp = (background *) params; - -double rtor = bp->sd->bs->rtor; - -spline_eval_ (bp->sid, 1, &r, 0, 1, bp->i_q, bp->i_T[1], bp->R); //R[n-Dmin+(j-Imin)*D1+k*D2], k=0 - new - -double q = bp->R[0]; - -double n = bp->R[2]; -double dn = bp->R[3]; - -double Ti = bp->R[4]; -double dTi = bp->R[5]; - -double Te = bp->R[6]; -double dTe = bp->R[7]; - -double dpress = boltz*((Ti+Te)*dn+(dTi+dTe)*n); - -double g = 1.0 + r*r/rtor/rtor/q/q; - -dy[0] = - 2.0*r*y[0]/(q*q*g*rtor*rtor) - 8.0*pi*dpress; - -return GSL_SUCCESS; -} - -/*-----------------------------------------------------------------*/ - -int jac_back (double r, const double y[], double *dfdy, double dfdt[], void *params) -{ -fprintf (stderr, "\nwarning: impossible code flow: jac_back is called!"); - -return GSL_SUCCESS; -} - -/*-----------------------------------------------------------------*/ - -// fortnum_ode_rhs adapter: forwards to the historical rhs_back, dropping the -// GSL return code (errors are signalled via the integrator status). -static void rhs_back_fn (double r, int n, const double y[], double dydt[], - void *ctx) -{ -(void) n; -rhs_back (r, y, dydt, ctx); -} - -/*-----------------------------------------------------------------*/ - -int background::calculate_equilibrium (void) -{ -/*! \fn calculate_equilibrium (void) - \brief Calculates magnetic field and plasma current densities out of the input profiles. - - \param -*/ - -const int Neq = 1; - -double rtor = sd->bs->rtor; -double B0 = sd->bs->B0; - -double rc = x[0]; - -spline_eval_ (sid, 1, &rc, 0, 0, i_q, i_q, R); - -double g = 1.0 + rc*rc/rtor/rtor/(R[0])/(R[0]); //starting value of u function - -double * u = new double[dimx]; - -u[0] = B0*B0*g; - -double uval[1] = {u[0]}; //current u value - -// Advance u continuously across the radial grid with the GSL-faithful rk8pd -// stepper, carrying the adaptive step across each output point. This mirrors -// the original gsl_odeiv_evolve_apply loop under -// gsl_odeiv_control_y_new(1e-16, 1e-16): the background equilibrium ODE is -// near-resonant at some grid points, where a per-segment reset (or a different -// 8(7) error norm) drifts from the recorded golden; one continuous rk8pd evolve -// reproduces the golden bit-for-bit. The starting step matches the golden: -// h0 = x[1] - x[0], the first segment width. -void *ode = fortnum_rk8pd_create (&rhs_back_fn, Neq, x[1] - rc, - 1.0e-16, 1.0e-16, 100000, this); -if (!ode) -{ - fprintf (stderr, "\ncalculate_equilibrium: failed to create ODE evolver"); - exit (1); -} - -double rcur = rc; - -for (int i = 1; i < dimx; ++i) -{ - int status = fortnum_rk8pd_integrate_to (ode, &rcur, x[i], uval); - - if (status != FORTNUM_OK) - { - fprintf (stderr, "\ncalculate_equilibrium: ODE solver failed at r = %le (status=%d)", rcur, status); - exit (1); - } - - u[i] = uval[0]; -} - -fortnum_rk8pd_destroy (ode); - -if (sd->bs->flag_debug > 1) //save u if needed -{ - char *full_name = new char[1024]; - sprintf (full_name, "%s%s", path2background, "u.dat"); - save_real_array (dimx, x, u, full_name); - delete [] full_name; -} - -/*calc bth, bz, b0*/ -//corresponding pointers: -double *q = y+(i_q)*dimx; -double *bth = y+(i_Bth)*dimx; -double *bz = y+(i_Bz)*dimx; -double *b0 = y+(i_B)*dimx; - -for (int i = 0; i < dimx; ++i) -{ - bz[i] = signum(B0)*sqrt(u[i]/(1.0+(x[i])*(x[i])/rtor/rtor/q[i]/q[i])); - - bth[i] = bz[i]*(x[i])/q[i]/rtor; - - b0[i] = sqrt (bth[i]*bth[i]+bz[i]*bz[i]); -} - -/*calculation hth hz:*/ -double *hth = y+(i_hth)*dimx; -double *hz = y+(i_hz)*dimx; - -for (int i = 0; i < dimx; ++i) -{ - hth[i] = bth[i]/b0[i]; - hz[i] = bz[i]/b0[i]; -} - -int ierr; - -/*splining bth, bz, b0, hth, hz: stored in a part of y array:*/ -spline_calc_ (sid, bth, i_Bth, i_hz, NULL, &ierr); - -/*calcs J0z, J0th*/ -//corresponding pointers: -double *jth = y+(i_J0th[2])*dimx; -double *jz = y+(i_J0z[2])*dimx; - -double dbz, dbth; - -for (int i = 0; i < dimx; ++i) -{ - spline_eval_ (sid, 1, x+i, 1, 1, i_Bth, i_Bz, R); - dbth = R[0]; - dbz = R[1]; - - jth[i] = - c/4.0/pi*dbz; /*J0th*/ - jz[i] = c/4.0/pi*(bth[i]/x[i]+dbth); /*J0z*/ -} - -/*splining jth, jz: stored in a part of y array:*/ -spline_calc_ (sid, jth, i_J0th[2], i_J0z[2], NULL, &ierr); - -delete [] u; - -return 0; -} - -/*-----------------------------------------------------------------*/ - -int background::check_and_spline_equilibrium (void) -{ -/*splines input profiles for bth, bz, jth, jz and calcs the rest for equilibrium*/ - -/*calc bth, bz, b0*/ -//corresponding pointers: -double *bth = y+(i_Bth)*dimx; -double *bz = y+(i_Bz)*dimx; -double *b0 = y+(i_B)*dimx; -double *hth = y+(i_hth)*dimx; -double *hz = y+(i_hz)*dimx; -double *jth = y+(i_J0th[2])*dimx; - -int i; -for (i=0; i 1.0e-6) - { - fprintf (stderr, "\nwarning: check_and_spline_equilibrium: r = %le\tdev = %le", x[i], dev); - } -} - -return 0; -} - -/*-----------------------------------------------------------------*/ - -int background::find_f0_parameters (void) -{ -int ierr; - -//renotation: -double *mass = sd->bs->mass; -double *charge = sd->bs->charge; -char *flag_back = sd->bs->flag_back; - -double *n = y + (i_n)*dimx; -double *Ti = y + (i_T[0])*dimx; -double *Te = y + (i_T[1])*dimx; -double *Vth = y + (i_Vth[2])*dimx; -double *Vz = y + (i_Vz[2])*dimx; -double *Er = y + (i_Er)*dimx; - -double *b0 = y + (i_B)*dimx; -double *bth = y + (i_Bth)*dimx; -double *hth = y + (i_hth)*dimx; -double *hz = y + (i_hz)*dimx; - -double *jth = y + (i_J0th[2])*dimx; -double *jz = y + (i_J0z[2])*dimx; - -double *dPhi0 = y + (i_dPhi0)*dimx; - -double *nui = y + (i_nu[0])*dimx; -double *nue = y + (i_nu[1])*dimx; - -double *n_i_p = y + (i_n_p[0])*dimx; -double *n_e_p = y + (i_n_p[1])*dimx; - -double *Vp_i_p = y + (i_Vp_p[0])*dimx; -double *Vp_e_p = y + (i_Vp_p[1])*dimx; - -double *Vt_i_p = y + (i_Vt_p[0])*dimx; -double *Vt_e_p = y + (i_Vt_p[1])*dimx; - -double Vs_tot, Vp_tot, Js_tot, Jp_tot; -double dpress, dn, dTi, dTe, Vsi_, Vse_; - -/*estimations for the f0 parameters:*/ -int i; - -double nuee, nuei, nuie, nuii; //freqs -double Lee, Lei, Lie, Lii; //Coulomb logs -double vf = 1.0; //velocity factor - -for (i=0; ibs->zion)*(nuie + nuii + 10.0); - nue[i] = (sd->bs->zele)*(nuee + nuei + 10.0); - - //density parameter: - n_i_p[i] = n[i]; - n_e_p[i] = n[i]; - - //thermal velocity: - Vt_i_p[i] = sqrt (boltz*Ti[i]/mass[0]); - Vt_e_p[i] = sqrt (boltz*Te[i]/mass[1]); - - //parallel velocity: - Vp_tot = hth[i]*Vth[i] + hz[i]*Vz[i]; - Jp_tot = hth[i]*jth[i] + hz[i]*jz[i]; - - Vp_i_p[i] = Vp_tot + Jp_tot*mass[1]/mass[0]/e/n[i]/(1.0+mass[1]/mass[0]); - Vp_e_p[i] = Vp_tot - Jp_tot/e/n[i]/(1.0+mass[1]/mass[0]); - - if (flag_dPhi0_calc > 0) //recalculate dPhi0 - { - //electric field: depends on a situation - //Vs: velocity for either electrons or ions - Vs_tot = hz[i]*Vth[i] - hth[i]*Vz[i]; - Js_tot = hz[i]*jth[i] - hth[i]*jz[i]; - - Vsi_ = Vs_tot + Js_tot*mass[1]/mass[0]/e/n[i]/(1.0+mass[1]/mass[0]); - Vse_ = Vs_tot - Js_tot/e/n[i]/(1.0+mass[1]/mass[0]); - - //one can only satisfy for the velocity of the one component or total: - spline_eval_ (sid, 1, x+i, 1, 1, i_n, i_T[1], R); - - dn = R[0]; - dTi = R[1]; - dTe = R[2]; - - //from equation: Vsi(x[i]) = Vsi_; - dpress = boltz*(Ti[i]*dn+dTi*n[i]); //ions dpressure - dPhi0[i] = Vsi_/c*b0[i]-dpress/charge[0]/n[i]; //el. field defined by ions - } - else //calculate dPhi0 from input Er profile - { - dPhi0[i] = - Er[i] + bth[i]*(sd->bs->V_gal_sys)/c; - } -} - -/*splining dPhi0, f0 parameters, nui, nue:*/ -spline_calc_ (sid, dPhi0, i_dPhi0, i_nu[1], NULL, &ierr); - -//density reestimation: -int spec; - -for (i=0; ibs->mass; -double *charge = sd->bs->charge; -char *flag_back = sd->bs->flag_back; - -const int num_moms = 16; -FILE **mom_files = new FILE *[num_moms]; - -char *full_name = new char[1024]; - -char moms_name[num_moms][10] = {{"ni_m"}, {"ne_m"}, {"Vth_m"}, {"Vz_m"}, - {"Vsi_m"}, {"Vse_m"}, {"Vpi_m"}, {"Vpe_m"}, - {"Vs0i_m"},{"Vs0e_m"},{"Ti_m"}, {"Te_m"}, - {"j0s_m"}, {"j0p_m"}, {"j0th_m"},{"j0z_m"}}; - -int i, k; - -//fprintf (stdout, "\nReminder: all quantities are computed in the moving frame!!!"); - -/*opening all files*/ -for (k=0; kbs->V_gal_sys; -*dPhi0 -= Bth*(sd->bs->V_gal_sys)/c; -} - -/*-----------------------------------------------------------------*/ - -void background::interp_basic_background_profiles_in_lab_frame (int dim, double *r, double *q, double *n, double *Ti, double *Te, double *Vth, double *Vz, double *dPhi0) -{ -for (int i=0; i -#include -#include -#include -#include - -#include "constants.h" -#include "eval_back.h" -#include "spline.h" - -/*-----------------------------------------------------------------*/ - -void eval_background_spec_independent_ (double *r, background **bpro, double *R) -{ -//evaluates B0, hth, hz, dPhi0 and 2 derivatives -background *bp = (background *)(*bpro); -spline_eval_ (bp->sid, 1, r, 0, 2, bp->i_B, bp->i_dPhi0, R); -} - -/*-----------------------------------------------------------------*/ - -void eval_f0_parameters_nu_and_derivs_ (double *r, int *spec, background **bpro, double *R) -{ -//evaluates n_p, Vp_p, Vt_p, nu + 2 derivatives -background *bp = (background *)(*bpro); -spline_eval_ (bp->sid, 1, r, 0, 2, bp->i_n_p[*spec], bp->i_nu[*spec], R); -} - -/*-----------------------------------------------------------------*/ - -void vs_0 (double r, int spec, const background *bp, double *res) -{ -double R[2]; - -spline_eval_ (bp->sid, 1, &r, 0, 1, bp->i_n, bp->i_n, R); - -double n = R[0]; -double dn = R[1]; - -spline_eval_ (bp->sid, 1, &r, 0, 1, bp->i_T[spec], bp->i_T[spec], R); - -double T = R[0]; -double dT = R[1]; - -double dpress = boltz*(dn*T+n*dT); - -double B; -spline_eval_ (bp->sid, 1, &r, 0, 0, bp->i_B, bp->i_B, &B); - -double dPhi0; -spline_eval_ (bp->sid, 1, &r, 0, 0, bp->i_dPhi0, bp->i_dPhi0, &dPhi0); - -*res = c/B*(dPhi0+dpress/(bp->sd->bs->charge[spec])/n); -} - -/*-----------------------------------------------------------------*/ - -void vs_0_f_ (double *r, int *spec, background **bp_ptr, double *vs) -{ -vs_0 (*r, *spec, (const background *)(*bp_ptr), vs); -} - -/*-----------------------------------------------------------------*/ - -double q (double r, const background *bp) -{ -double ans; - -spline_eval_ (bp->sid, 1, &r, 0, 0, bp->i_q, bp->i_q, &ans); - -return ans; -} - -/*-----------------------------------------------------------------*/ - -void eval_hthz_ (double *r, int *omin, int *omax, background **bpro, double *R) -{ -//evaluates hth, hz derivs omin...omax - -background *bp = (background *)(*bpro); - -spline_eval_ (bp->sid, 1, r, *omin, *omax, bp->i_hth, bp->i_hz, R); -} - -/*-----------------------------------------------------------------*/ - -void eval_hthz (double r, int omin, int omax, const background *bp, double *R) -{ -//evaluates hth, hz derivs omin...omax -spline_eval_ (bp->sid, 1, &r, omin, omax, bp->i_hth, bp->i_hz, R); -} - -/*-----------------------------------------------------------------*/ - -void eval_B0_ht_hz_n0_Vz (double r, const background *bp, double *R) -{ -spline_eval_ (bp->sid, 1, &r, 0, 0, bp->i_B, bp->i_hz, R+0); //B, hth, hz -spline_eval_ (bp->sid, 1, &r, 0, 0, bp->i_n, bp->i_n, R+3); //n -spline_eval_ (bp->sid, 1, &r, 0, 0, bp->i_Vz[2], bp->i_Vz[2], R+4); //Vz - total -} - -/*-----------------------------------------------------------------*/ - -void eval_Bt_dBz_dpress (double r, const background *bp, double *R) -{ -spline_eval_ (bp->sid, 1, &r, 0, 0, bp->i_Bth, bp->i_Bth, R+0); //B0th -spline_eval_ (bp->sid, 1, &r, 1, 1, bp->i_Bz, bp->i_Bz, R+1); //dBz - -double S[4]; - -spline_eval_ (bp->sid, 1, &r, 0, 1, bp->i_n, bp->i_n, S); - -double n = S[0]; -double dn = S[1]; - -spline_eval_ (bp->sid, 1, &r, 0, 1, bp->i_T[0], bp->i_T[1], S); - -double Ti = S[0], dTi = S[1]; -double Te = S[2], dTe = S[3]; - -R[2] = boltz*(dn*(Ti+Te)+n*(dTi+dTe)); //dpress -} - -/*-----------------------------------------------------------------*/ - -void eval_Bt_Jt_Jz (double r, const background *bp, double *R) -{ -spline_eval_ (bp->sid, 1, &r, 0, 0, bp->i_Bth, bp->i_Bth, R+0); //B0th -spline_eval_ (bp->sid, 1, &r, 0, 0, bp->i_J0th[2], bp->i_J0z[2], R+1); //Jt and Jz -} - -/*-----------------------------------------------------------------*/ - -void eval_Bt_dBt_Bz_dBz (double r, const background *bp, double *R) -{ -spline_eval_ (bp->sid, 1, &r, 0, 1, bp->i_Bth, bp->i_Bz, R); -} - -/*-----------------------------------------------------------------*/ - -void eval_p_dp (double r, const background *bp, double *R) -{ -double S[4]; - -spline_eval_ (bp->sid, 1, &r, 0, 1, bp->i_n, bp->i_n, S); - -double n = S[0]; -double dn = S[1]; - -spline_eval_ (bp->sid, 1, &r, 0, 1, bp->i_T[0], bp->i_T[1], S); - -double Ti = S[0], dTi = S[1]; -double Te = S[2], dTe = S[3]; - -R[0] = boltz*(n*(Ti+Te)); //pressure -R[1] = boltz*(dn*(Ti+Te)+n*(dTi+dTe)); //pressure' -} - -/*-----------------------------------------------------------------*/ - -void eval_mass_density (double r, const background *bp, double *R) -{ -spline_eval_ (bp->sid, 1, &r, 0, 0, bp->i_n, bp->i_n, R); - -R[0] *= bp->sd->bs->mass[0]; -} - -/*-----------------------------------------------------------------*/ - -void eval_dmass_density (double r, const background *bp, double *R) -{ -spline_eval_ (bp->sid, 1, &r, 1, 1, bp->i_n, bp->i_n, R); - -R[0] *= bp->sd->bs->mass[0]; -} - -/*-----------------------------------------------------------------*/ - -void eval_Bt_Bz (double r, const background *bp, double *R) -{ -spline_eval_ (bp->sid, 1, &r, 0, 0, bp->i_Bth, bp->i_Bz, R); -} - -/*-----------------------------------------------------------------*/ - -void eval_Bt (double r, const background *bp, double *R) -{ -spline_eval_ (bp->sid, 1, &r, 0, 0, bp->i_Bth, bp->i_Bth, R); -} - -/*-----------------------------------------------------------------*/ - -void eval_Bz (double r, const background *bp, double *R) -{ -spline_eval_ (bp->sid, 1, &r, 0, 0, bp->i_Bz, bp->i_Bz, R); -} - -/*-----------------------------------------------------------------*/ - -void eval_Vt (double r, const background *bp, double *R) -{ -spline_eval_ (bp->sid, 1, &r, 0, 0, bp->i_Vth[2], bp->i_Vth[2], R); -} - -/*-----------------------------------------------------------------*/ - -void eval_Vz (double r, const background *bp, double *R) -{ -spline_eval_ (bp->sid, 1, &r, 0, 0, bp->i_Vz[2], bp->i_Vz[2], R); -} - -/*-----------------------------------------------------------------*/ diff --git a/KiLCA/background/eval_back.h b/KiLCA/background/eval_back.h deleted file mode 100644 index fd69c257..00000000 --- a/KiLCA/background/eval_back.h +++ /dev/null @@ -1,52 +0,0 @@ -/*! \file eval_back.h - \brief Functions used to evaluate the splined background profiles and parameters. -*/ - -#ifndef EVAL_BACK_INCLUDE - -#define EVAL_BACK_INCLUDE - -#include "background.h" - -double q (double r, const background *bp); - -void eval_hthz (double r, int omin, int omax, const background *bp, double *R); - -void eval_Bt_Jt_Jz (double r, const background *bp, double *R); - -void eval_Bt_dBz_dpress (double r, const background *bp, double *R); - -void eval_B0_ht_hz_n0_Vz (double r, const background *bp, double *R); - -void eval_Bt_dBt_Bz_dBz (double r, const background *bp, double *R); - -void eval_p_dp (double r, const background *bp, double *R); - -void eval_mass_density (double r, const background *bp, double *R); - -void eval_dmass_density (double r, const background *bp, double *R); - -void eval_Bt_Bz (double r, const background *bp, double *R); - -void eval_Bt (double r, const background *bp, double *R); - -void eval_Bz (double r, const background *bp, double *R); - -void eval_Vt (double r, const background *bp, double *R); - -void eval_Vz (double r, const background *bp, double *R); - -extern "C" -{ -void eval_background_spec_independent_ (double *r, background **bpro, double *R); - -void eval_f0_parameters_nu_and_derivs_ (double *r, int *spec, background **bpro, double *R); - -void vs_0 (double r, int spec, const background *bp, double *res); - -void vs_0_f_ (double *r, int *spec, background **bp_ptr, double *vs); - -void eval_hthz_ (double *r, int *omin, int *omax, background **bpro, double *R); -} - -#endif diff --git a/KiLCA/code_settings.h b/KiLCA/code_settings.h deleted file mode 100644 index 4e9360c4..00000000 --- a/KiLCA/code_settings.h +++ /dev/null @@ -1,9 +0,0 @@ -#define DEBUG_FLAG 0 - -#define CALC_EIGEN_DECOMPOSITION 0 - -#define SORT_DISPERSION_PROFILES 0 - -#define USE_JACOBIAN_IN_ODE_SOLVER 1 - -#define USE_SPLINES_IN_RHS_EVALUATION 0 diff --git a/KiLCA/core/constants.h b/KiLCA/core/constants.h deleted file mode 100644 index 439ff4c3..00000000 --- a/KiLCA/core/constants.h +++ /dev/null @@ -1,31 +0,0 @@ -/*! \file constants.h - \brief The definitions of some constants used throughout the library. -*/ - -#ifndef CONSTANTS_INCLUDE - -#define CONSTANTS_INCLUDE - -#include - -using namespace std; - -const double pi = 3.141592653589793238462643383279502884197; -const double eul = 0.5772156649015328606065120900824024310422; - -const double boltz = 1.60216428e-12; /* erg/eV */ - -const double c = 29979245800.0; - -const double m_p = 1.67262158e-24; /*proton mass*/ -const double m_e = 9.10938185917485e-28; /*electron mass*/ - -const double e = 4.8032e-10; /*elementary charge*/ - -const double GAMMA = 5.0/3.0; /*adiabatic constant*/ - -const complex O(0.0e0, 0.0e0), E(1.0e0, 0.0e0), I(0.0e0, 1.0e0); - -const double sqrt2pi = sqrt(2.0e0*pi); - -#endif diff --git a/KiLCA/core/constants_m_32bit.f90 b/KiLCA/core/constants_m_32bit.f90 index bdb17dbf..0298754e 100644 --- a/KiLCA/core/constants_m_32bit.f90 +++ b/KiLCA/core/constants_m_32bit.f90 @@ -32,7 +32,8 @@ module constants complex(dpc), parameter :: im = (0.0d0, 1.0d0) -real(dp), parameter :: c = 29979245800.0 !speed of light in vacuum +real(dp), parameter :: c = real(29979245800.0_sp, dp) !speed of light in vacuum; legacy single-precision value (29979246592.0) preserved for golden-record parity of Fortran-side physics; C++-ported code uses a local double-precision c + real(dp), parameter :: mp = 1.67262158d-24 !proton mass real(dp), parameter :: me = mp/1.8361526675d3 !electron mass real(dp), parameter :: e = 4.8032d-10 !elementary charge diff --git a/KiLCA/core/constants_m_64bit.f90 b/KiLCA/core/constants_m_64bit.f90 index d0c3473f..0b861ae7 100644 --- a/KiLCA/core/constants_m_64bit.f90 +++ b/KiLCA/core/constants_m_64bit.f90 @@ -32,7 +32,8 @@ module constants complex(dpc), parameter :: im = (0.0d0, 1.0d0) -real(dp), parameter :: c = 29979245800.0 !speed of light in vacuum +real(dp), parameter :: c = real(29979245800.0_sp, dp) !speed of light in vacuum; legacy single-precision value (29979246592.0) preserved for golden-record parity of Fortran-side physics; C++-ported code uses a local double-precision c + real(dp), parameter :: mp = 1.67262158d-24 !proton mass real(dp), parameter :: me = mp/1.8361526675d3 !electron mass real(dp), parameter :: e = 4.8032d-10 !elementary charge diff --git a/KiLCA/core/core.cpp b/KiLCA/core/core.cpp deleted file mode 100644 index d694f843..00000000 --- a/KiLCA/core/core.cpp +++ /dev/null @@ -1,245 +0,0 @@ -/*! \file core.cpp - \brief The implementation of core_data class. -*/ - -#include -#include -#include -#include -#include - -#include "core.h" -#include "settings.h" -#include "calc_eigmode.h" - -/*******************************************************************/ - -core_data::core_data (char *path) -{ -/*! \fn core_data (char *path) - \brief Constructor. - - \param path path to top level run dir of a project. -*/ - -//checks if pointer size and Fortran integer size are compatibile - -int pp; //fortran integer size to store the C pointers - -get_pointer_precision_ (&pp); //gets size of integers used to store C pointers in Fortran - -//technical check: important for passing pointers to fortran as integers -if (sizeof(uintptr_t) != sizeof(core_data *) || pp != sizeof(uintptr_t)) -{ - fprintf (stdout, "\nwarning: core_data: sizeof(uintptr_t)=%ld != sizeof(ptr)=%ld != pp=%d\n", sizeof(uintptr_t), sizeof(core_data *), pp); - fprintf (stdout, "\nset apropriate value for integer, parameter :: pp in the file constants_m.f90"); - exit(1); -} - -path2project = new char[1024]; -strcpy (path2project, path); -} - -/*******************************************************************/ - -core_data::~core_data (void) -{ -/*! \fn ~core_data (void) - \brief Destructor. Frees all allocated memory hierarchically. -*/ - -// Do NOT delete sd intentionally, as the static object, this member points to, will be reused -// in the next iteration of the time evolution. - -delete bp; - -delete [] path2project; - -if (mda == 0) return; - -for (int ind=0; indread_settings(); - } - sd = static_settings_vacuum; - } - else if (p2pstr.find("flre") != std::string::npos) - { - if (static_settings_flre == nullptr) - { - static_settings_flre = new settings{path2project}; - static_settings_flre->read_settings(); - } - sd = static_settings_flre; - } - else - { - std::cerr << "\nError: calc_and_set_mode_independent_core_data: unknown project type in path: " << path2project << '\n'; - exit(1); - } - - set_settings_in_core_module_(&sd); - -bp = new background (sd); - -set_background_in_core_module_ (&bp); - -//loads and splines initial background profiles, computes equilibrium magnetic field, -//currents, f0 parameters and other stuff: -if (sd->bs->calc_back > 0) -{ - bp->set_background_profiles_from_files (); -} -else if(sd->bs->calc_back < 0) -{ - bp->set_background_profiles_from_interface (); -} -else -{ - fprintf (stderr, "\nwarning: calc_and_set_mode_independent_core_data: unknown flag in background.in!\n"); - exit(1); -} -} - -/*******************************************************************/ - -void core_data::calc_and_set_mode_dependent_core_data_antenna (void) -{ -//allocates modes array in core struct: -dim = sd->as->dma; -mda = new mode_data * [dim]; - -complex olab = (2.0*pi)*(sd->as->flab); - -//loop over modes array: -for (int ind=0; indas->modes[2*ind+0]; - int n = sd->as->modes[2*ind+1]; - - mda[ind] = new mode_data (m, n, olab, (const settings *)sd, (const background *)bp); - - mda[ind]->calc_all_mode_data (); - - delete mda[ind]; //delete mode_data object (if only needed) - mda[ind] = 0; - - clear_all_data_in_mode_data_module_ (); //clean up fortran module data -} -} - -/*******************************************************************/ - -void core_data::calc_and_set_mode_dependent_core_data_eigmode (void) -{ -//allocates modes array in core struct: -dim = sd->as->dma; -mda = new mode_data * [dim]; - -//loop over modes array: -for (int ind=0; indas->modes[2*ind+0]; - int n = sd->as->modes[2*ind+1]; - - if (sd->es->search_flag == 1) - { - //loop over frequences: - loop_over_frequences (ind, m, n, this); - } - else if (sd->es->search_flag == 0) - { - //complex zero search by gsl real solver: - find_det_zeros (ind, m, n, this); - } - else if (sd->es->search_flag == -1) - { - //all complex zeros search by complex zero finder: - find_eigmodes (ind, m, n, this); - } - else - { - fprintf (stdout, "\nError: unknown search_flag in eigmode options file: %d.", sd->es->search_flag); - exit(1); - } -} -} - -/*******************************************************************/ - -void core_data::calc_and_set_mode_dependent_core_data_antenna_interface (void) -{ - //allocates modes array in core struct: - dim = sd->as->dma; - mda = new mode_data * [dim]; - - complex olab = (2.0*pi)*(sd->as->flab); - - //loop over modes array: - for (int ind=0; indas->modes[2*ind+0]; - int n = sd->as->modes[2*ind+1]; - - mda[ind] = new mode_data (m, n, olab, (const settings *)sd, (const background *)bp); - - mda[ind]->calc_all_mode_data (); - - clear_all_data_in_mode_data_module_ (); //clean up fortran module data - } -} - -/*******************************************************************/ - -void core_data::calc_and_set_mode_dependent_core_data_antenna_interface (int m, int n, int flag) -{ -//allocates modes array in core struct: -dim = 1; -mda = new mode_data * [dim]; - -complex olab = (2.0*pi)*(sd->as->flab); - -//loop over modes array: -for (int ind=0; indcalc_all_mode_data (flag); - - clear_all_data_in_mode_data_module_ (); //clean up fortran module data -} -} - -/*******************************************************************/ diff --git a/KiLCA/core/core.h b/KiLCA/core/core.h deleted file mode 100644 index 2c04e896..00000000 --- a/KiLCA/core/core.h +++ /dev/null @@ -1,69 +0,0 @@ -/*! \file core.h - \brief The declaration of core_data class. -*/ - -#ifndef CORE_INCLUDE - -#define CORE_INCLUDE - -#include - -#include "code_settings.h" - -#include "settings.h" -#include "background.h" -#include "mode.h" - -using namespace :: std; - -/*! \class core_data - \brief The top level class of KiLCA library. -*/ -class core_data -{ -public: - char *path2project; //! The top-level KiLCA orchestrator, formerly the C++ core_data class +!> (core.{h,cpp}). Per-instance handle (same c_loc/transfer pattern as +!> cond_profiles etc - core_data is genuinely instantiated multiple times, +!> once per wave_code_interface_64bit.f90/QL-Balance call). +!> +!> eigmode/calc_eigmode.cpp and eigmode/find_eigmodes.cpp (the zersol-based +!> complex-root search, still C++, a separate and substantially larger +!> translation unit) call back into this module's getters with a handle +!> instead of the oracle's `core_data *this` - only their call SIGNATURES +!> were updated for this step, not their own internal root-finding logic. +module kilca_core_data_m + use, intrinsic :: iso_c_binding, only: c_int, c_intptr_t, c_double, c_char, & + c_ptr, c_loc, c_f_pointer, c_null_char + use constants, only: dp, pi + use kilca_settings_m, only: settings_create_, settings_read_settings_, & + settings_get_path2project_ + use kilca_mode_data_m, only: mode_data_create_, mode_data_destroy_, & + mode_data_calc_all_mode_data_ + implicit none + private + + public :: core_data_create_, core_data_destroy_ + public :: core_data_calc_and_set_mode_independent_ + public :: core_data_calc_and_set_mode_dependent_antenna_ + public :: core_data_calc_and_set_mode_dependent_eigmode_ + public :: core_data_calc_and_set_mode_dependent_antenna_interface_ + public :: core_data_calc_and_set_mode_dependent_antenna_interface_mn_ + public :: core_data_get_dim_, core_data_get_mda_element_, core_data_set_mda_element_ + public :: core_data_get_bp_, core_data_get_sd_ + public :: core_data_get_path2project_ + + type :: core_data_t + character(len=1024) :: path2project = '' + integer(c_intptr_t) :: sd = 0 + integer(c_intptr_t) :: bp = 1_c_intptr_t + integer :: dim = 0 + integer(c_intptr_t), allocatable :: mda(:) + end type core_data_t + + !> Static settings caches (one per project-type substring match), + !> mirroring core_data::calc_and_set_mode_independent_core_data's own + !> static_settings_vacuum/static_settings_flre - settings reading has + !> always been effectively global (see kilca_settings_m), so this + !> caching avoids re-parsing the same .in files across core_data + !> instances for the same project type. + integer(c_intptr_t) :: static_settings_vacuum = 0 + integer(c_intptr_t) :: static_settings_flre = 0 + + interface + subroutine get_pointer_precision(ppp) bind(C, name="get_pointer_precision_") + import :: c_int + integer(c_int), intent(out) :: ppp + end subroutine get_pointer_precision + + function background_create(path2project_p) bind(C, name="background_create_") result(handle) + import :: c_ptr, c_intptr_t + type(c_ptr), value :: path2project_p + integer(c_intptr_t) :: handle + end function background_create + + integer(c_int) function get_background_calc_back() bind(C, name="get_background_calc_back_") + import :: c_int + end function get_background_calc_back + + subroutine background_set_profiles_from_files() & + bind(C, name="background_set_profiles_from_files_") + end subroutine background_set_profiles_from_files + + subroutine background_set_profiles_from_interface() & + bind(C, name="background_set_profiles_from_interface_") + end subroutine background_set_profiles_from_interface + + integer(c_int) function get_antenna_dma() bind(C, name="get_antenna_dma_") + import :: c_int + end function get_antenna_dma + + subroutine get_antenna_flab(re, im) bind(C, name="get_antenna_flab_") + import :: c_double + real(c_double), intent(out) :: re, im + end subroutine get_antenna_flab + + subroutine get_antenna_mode(ind, m, n) bind(C, name="get_antenna_mode_") + import :: c_int + integer(c_int), value :: ind + integer(c_int), intent(out) :: m, n + end subroutine get_antenna_mode + + integer(c_int) function get_eigmode_search_flag() bind(C, name="get_eigmode_search_flag_") + import :: c_int + end function get_eigmode_search_flag + + subroutine clear_all_data_in_mode_data_module() & + bind(C, name="clear_all_data_in_mode_data_module_") + end subroutine clear_all_data_in_mode_data_module + + !> Pre-existing legacy Fortran (core_m.f90), stores the settings + !> handle into the `core` module's sd_ptr - by-reference, matching + !> its `integer(pp), intent(in) :: sd` dummy. + subroutine set_settings_in_core_module(sd) bind(C, name="set_settings_in_core_module_") + import :: c_intptr_t + integer(c_intptr_t), intent(in) :: sd + end subroutine set_settings_in_core_module + + !> Fortran (eigmode/eigmode_solve_m.f90), eigenmode root-search + !> strategies - take the opaque core_data handle in place of the + !> oracle's `core_data *cd`. + function loop_over_frequences(ind, m, n, cd) bind(C, name="loop_over_frequences") result(stat) + import :: c_int, c_intptr_t + integer(c_int), value :: ind, m, n + integer(c_intptr_t), value :: cd + integer(c_int) :: stat + end function loop_over_frequences + + function find_det_zeros(ind, m, n, cd) bind(C, name="find_det_zeros") result(stat) + import :: c_int, c_intptr_t + integer(c_int), value :: ind, m, n + integer(c_intptr_t), value :: cd + integer(c_int) :: stat + end function find_det_zeros + + function find_eigmodes(ind, m, n, cd) bind(C, name="find_eigmodes") result(stat) + import :: c_int, c_intptr_t + integer(c_int), value :: ind, m, n + integer(c_intptr_t), value :: cd + integer(c_int) :: stat + end function find_eigmodes + end interface + +contains + + function core_data_create_(path) result(handle) bind(C, name="core_data_create_") + character(kind=c_char), intent(in) :: path(*) + integer(c_intptr_t) :: handle + + type(core_data_t), pointer :: cd + integer(c_int) :: pp_size + + !> Mirrors core_data::core_data's sizeof(uintptr_t) != sizeof(pp) + !> sanity check: pp (constants_m_64bit.f90) and handle are both + !> meant to be 8-byte (64-bit) quantities on this platform. + call get_pointer_precision(pp_size) + if (pp_size /= storage_size(handle)/8) then + write (*, '(a,i0,a,i0)') & + 'warning: core_data: pointer-precision mismatch: pp=', pp_size, & + ' sizeof(handle)=', storage_size(handle)/8 + stop 1 + end if + + allocate (cd) + cd%path2project = c_string_to_fortran(path) + + handle = transfer(c_loc(cd), handle) + end function core_data_create_ + + subroutine core_data_destroy_(handle) bind(C, name="core_data_destroy_") + integer(c_intptr_t), value :: handle + type(core_data_t), pointer :: cd + integer :: ind + + if (handle == 0_c_intptr_t) return + call handle_to_core_data(handle, cd) + + ! sd intentionally not destroyed: it is one of the static, reused + ! settings caches above, matching the oracle's own comment ("Do + ! NOT delete sd intentionally, as the static object ... will be + ! reused"). bp is a singleton sentinel, nothing to free. + + if (allocated(cd%mda)) then + do ind = 1, cd%dim + if (cd%mda(ind) /= 0_c_intptr_t) call mode_data_destroy_(cd%mda(ind)) + end do + deallocate (cd%mda) + end if + + deallocate (cd) + end subroutine core_data_destroy_ + + subroutine core_data_calc_and_set_mode_independent_(handle) & + bind(C, name="core_data_calc_and_set_mode_independent_") + integer(c_intptr_t), value :: handle + type(core_data_t), pointer :: cd + character(kind=c_char), allocatable, target :: cpath(:) + character(len=1024) :: sd_path2project + + call handle_to_core_data(handle, cd) + + if (index(cd%path2project, 'vacuum') > 0) then + if (static_settings_vacuum == 0_c_intptr_t) then + cpath = to_cstr(cd%path2project) + static_settings_vacuum = settings_create_(cpath) + call settings_read_settings_(static_settings_vacuum) + end if + cd%sd = static_settings_vacuum + else if (index(cd%path2project, 'flre') > 0) then + if (static_settings_flre == 0_c_intptr_t) then + cpath = to_cstr(cd%path2project) + static_settings_flre = settings_create_(cpath) + call settings_read_settings_(static_settings_flre) + end if + cd%sd = static_settings_flre + else + write (*, '(a,a)') & + 'Error: calc_and_set_mode_independent_core_data: unknown project type in path: ', & + trim(cd%path2project) + stop 1 + end if + + call set_settings_in_core_module(cd%sd) + + call settings_get_path2project_(cd%sd, sd_path2project) + cpath = to_cstr(sd_path2project) + cd%bp = background_create(c_loc(cpath)) + + if (get_background_calc_back() > 0) then + call background_set_profiles_from_files() + else if (get_background_calc_back() < 0) then + call background_set_profiles_from_interface() + else + write (*, '(a)') & + 'warning: calc_and_set_mode_independent_core_data: unknown flag in background.in!' + stop 1 + end if + end subroutine core_data_calc_and_set_mode_independent_ + + subroutine core_data_calc_and_set_mode_dependent_antenna_(handle) & + bind(C, name="core_data_calc_and_set_mode_dependent_antenna_") + integer(c_intptr_t), value :: handle + type(core_data_t), pointer :: cd + real(dp) :: flab_re, flab_im + complex(dp) :: olab + character(len=1024) :: sd_path2project + integer :: ind, m, n + + call handle_to_core_data(handle, cd) + + cd%dim = get_antenna_dma() + if (allocated(cd%mda)) deallocate (cd%mda) + allocate (cd%mda(cd%dim)) + + call get_antenna_flab(flab_re, flab_im) + olab = (2.0_dp*pi)*cmplx(flab_re, flab_im, dp) + + do ind = 1, cd%dim + call get_antenna_mode(int(ind - 1, c_int), m, n) + + call settings_get_path2project_(cd%sd, sd_path2project) + cd%mda(ind) = mode_data_create_(m, n, real(olab, dp), aimag(olab), cd%sd, cd%bp, & + trim(sd_path2project)//c_null_char) + + call mode_data_calc_all_mode_data_(cd%mda(ind), 0_c_int) + + call mode_data_destroy_(cd%mda(ind)) + cd%mda(ind) = 0 + + call clear_all_data_in_mode_data_module() + end do + end subroutine core_data_calc_and_set_mode_dependent_antenna_ + + subroutine core_data_calc_and_set_mode_dependent_eigmode_(handle) & + bind(C, name="core_data_calc_and_set_mode_dependent_eigmode_") + integer(c_intptr_t), value :: handle + type(core_data_t), pointer :: cd + integer :: ind, m, n, stat_unused + + call handle_to_core_data(handle, cd) + + cd%dim = get_antenna_dma() + if (allocated(cd%mda)) deallocate (cd%mda) + allocate (cd%mda(cd%dim)) + cd%mda = 0 + + do ind = 1, cd%dim + call get_antenna_mode(int(ind - 1, c_int), m, n) + + select case (get_eigmode_search_flag()) + case (1) + stat_unused = loop_over_frequences(int(ind - 1, c_int), m, n, handle) + case (0) + stat_unused = find_det_zeros(int(ind - 1, c_int), m, n, handle) + case (-1) + stat_unused = find_eigmodes(int(ind - 1, c_int), m, n, handle) + case default + write (*, '(a,i0,a)') 'Error: unknown search_flag in eigmode options file: ', & + get_eigmode_search_flag(), '.' + stop 1 + end select + end do + end subroutine core_data_calc_and_set_mode_dependent_eigmode_ + + subroutine core_data_calc_and_set_mode_dependent_antenna_interface_(handle) & + bind(C, name="core_data_calc_and_set_mode_dependent_antenna_interface_") + integer(c_intptr_t), value :: handle + type(core_data_t), pointer :: cd + real(dp) :: flab_re, flab_im + complex(dp) :: olab + character(len=1024) :: sd_path2project + integer :: ind, m, n + + call handle_to_core_data(handle, cd) + + cd%dim = get_antenna_dma() + if (allocated(cd%mda)) deallocate (cd%mda) + allocate (cd%mda(cd%dim)) + + call get_antenna_flab(flab_re, flab_im) + olab = (2.0_dp*pi)*cmplx(flab_re, flab_im, dp) + + do ind = 1, cd%dim + call get_antenna_mode(int(ind - 1, c_int), m, n) + + call settings_get_path2project_(cd%sd, sd_path2project) + cd%mda(ind) = mode_data_create_(m, n, real(olab, dp), aimag(olab), cd%sd, cd%bp, & + trim(sd_path2project)//c_null_char) + + call mode_data_calc_all_mode_data_(cd%mda(ind), 0_c_int) + + call clear_all_data_in_mode_data_module() + end do + end subroutine core_data_calc_and_set_mode_dependent_antenna_interface_ + + subroutine core_data_calc_and_set_mode_dependent_antenna_interface_mn_(handle, m, n, flag) & + bind(C, name="core_data_calc_and_set_mode_dependent_antenna_interface_mn_") + integer(c_intptr_t), value :: handle + integer(c_int), value :: m, n, flag + type(core_data_t), pointer :: cd + real(dp) :: flab_re, flab_im + complex(dp) :: olab + character(len=1024) :: sd_path2project + integer :: ind + + call handle_to_core_data(handle, cd) + + cd%dim = 1 + if (allocated(cd%mda)) deallocate (cd%mda) + allocate (cd%mda(cd%dim)) + + call get_antenna_flab(flab_re, flab_im) + olab = (2.0_dp*pi)*cmplx(flab_re, flab_im, dp) + + do ind = 1, cd%dim + call settings_get_path2project_(cd%sd, sd_path2project) + cd%mda(ind) = mode_data_create_(int(m), int(n), real(olab, dp), aimag(olab), cd%sd, & + cd%bp, trim(sd_path2project)//c_null_char) + + call mode_data_calc_all_mode_data_(cd%mda(ind), flag) + + call clear_all_data_in_mode_data_module() + end do + end subroutine core_data_calc_and_set_mode_dependent_antenna_interface_mn_ + + !> ---- accessors for still-C++ callers (wave_code_interface.cpp, + !> eigmode/calc_eigmode.cpp, eigmode/find_eigmodes.cpp) ---- + + integer(c_int) function core_data_get_dim_(handle) bind(C, name="core_data_get_dim_") result(res) + integer(c_intptr_t), value :: handle + type(core_data_t), pointer :: cd + call handle_to_core_data(handle, cd) + res = cd%dim + end function core_data_get_dim_ + + function core_data_get_mda_element_(handle, ind) bind(C, name="core_data_get_mda_element_") & + result(res) + integer(c_intptr_t), value :: handle + integer(c_int), value :: ind + integer(c_intptr_t) :: res + type(core_data_t), pointer :: cd + call handle_to_core_data(handle, cd) + res = cd%mda(int(ind) + 1) + end function core_data_get_mda_element_ + + !> Lets callers (eigmode/eigmode_solve_m.f90's determinant evaluation) + !> write a freshly-created mode_data handle into cd->mda[ind] the same + !> way the oracle did via direct field assignment. + subroutine core_data_set_mda_element_(handle, ind, val) & + bind(C, name="core_data_set_mda_element_") + integer(c_intptr_t), value :: handle + integer(c_int), value :: ind + integer(c_intptr_t), value :: val + type(core_data_t), pointer :: cd + call handle_to_core_data(handle, cd) + cd%mda(int(ind) + 1) = val + end subroutine core_data_set_mda_element_ + + function core_data_get_bp_(handle) bind(C, name="core_data_get_bp_") result(res) + integer(c_intptr_t), value :: handle + integer(c_intptr_t) :: res + type(core_data_t), pointer :: cd + call handle_to_core_data(handle, cd) + res = cd%bp + end function core_data_get_bp_ + + function core_data_get_sd_(handle) bind(C, name="core_data_get_sd_") result(res) + integer(c_intptr_t), value :: handle + integer(c_intptr_t) :: res + type(core_data_t), pointer :: cd + call handle_to_core_data(handle, cd) + res = cd%sd + end function core_data_get_sd_ + + subroutine core_data_get_path2project_(handle, buf) bind(C, name="core_data_get_path2project_") + integer(c_intptr_t), value :: handle + character(kind=c_char), intent(out) :: buf(*) + type(core_data_t), pointer :: cd + integer :: i, n + call handle_to_core_data(handle, cd) + n = len_trim(cd%path2project) + do i = 1, n + buf(i) = cd%path2project(i:i) + end do + buf(n + 1) = c_null_char + end subroutine core_data_get_path2project_ + + subroutine handle_to_core_data(handle, cd) + integer(c_intptr_t), value :: handle + type(core_data_t), pointer, intent(out) :: cd + type(c_ptr) :: cp + cp = transfer(handle, cp) + call c_f_pointer(cp, cd) + end subroutine handle_to_core_data + + function to_cstr(s) result(c) + character(len=*), intent(in) :: s + character(kind=c_char), allocatable :: c(:) + integer :: i, n + n = len_trim(s) + allocate (c(n + 1)) + do i = 1, n + c(i) = s(i:i) + end do + c(n + 1) = c_null_char + end function to_cstr + + function c_string_to_fortran(cstr) result(fstr) + character(kind=c_char), intent(in) :: cstr(*) + character(len=1024) :: fstr + integer :: i + fstr = '' + i = 0 + do + if (cstr(i + 1) == c_null_char .or. i >= 1024) exit + fstr(i + 1:i + 1) = cstr(i + 1) + i = i + 1 + end do + end function c_string_to_fortran + +end module kilca_core_data_m diff --git a/KiLCA/core/output_sett.cpp b/KiLCA/core/output_sett.cpp deleted file mode 100644 index ba70182e..00000000 --- a/KiLCA/core/output_sett.cpp +++ /dev/null @@ -1,100 +0,0 @@ -/*! \file output_sett.h - \brief The implementation of output_sett class. -*/ - -#include -#include -#include -#include - -#include "output_sett.h" -#include "shared.h" -#include "inout.h" -#include "constants.h" - -/*****************************************************************************/ - -void output_sett::read_settings (char *path) -{ -char *file_set = new char[1024]; - -sprintf (file_set, "%s/output.in", path); - -FILE *in; - -if ((in=fopen (file_set, "r"))==NULL) -{ - fprintf(stderr, "\nerror: read_settings: failed to open file %s\a\n", file_set); - exit(0); -} - -//reading: check for consistence with file! -char *str_buf = new char[1024]; //str buffer - -//Run settings: -read_line_2skip_it (in, &str_buf); -read_line_2get_int (in, &(flag_background)); -read_line_2get_int (in, &(flag_emfield)); -read_line_2get_int (in, &(flag_additional)); -read_line_2get_int (in, &(flag_dispersion)); -read_line_2skip_it (in, &str_buf); - -read_line_2skip_it (in, &str_buf); -read_line_2get_int (in, &(flag_debug)); -read_line_2skip_it (in, &str_buf); - -num_quants = 8; - -flag_quants = new int[num_quants]; - -read_line_2skip_it (in, &str_buf); - -int i; -for (i=0; i Output settings, formerly the C++ output_sett class. The Fortran output_data +!> module parses output.in and serves the flags to the remaining C++ via bind(C) +!> getters. Layout matches output_sett::read_settings exactly: a header line, +!> the four run flags, two skipped lines, flag_debug, two skipped lines, then +!> num_quants(=8) per-quantity flags. +module output_data + +use constants, only: dp + +integer :: flag_background +integer :: flag_emfield +integer :: flag_additional +integer :: flag_dispersion +integer :: flag_debug +integer :: num_quants +integer, dimension(:), allocatable :: flag_quants + +end module + +!------------------------------------------------------------------------------ + +subroutine read_output_settings(path) bind(C, name="read_output_settings_") + +use, intrinsic :: iso_c_binding, only: c_char, c_null_char +use, intrinsic :: iso_fortran_env, only: error_unit +use output_data + +character(kind=c_char), dimension(*), intent(in) :: path + +character(len=1024) :: fpath, fname, buf, before +integer :: i, u, ios, pos, k + +fpath = '' +i = 1 +do + if (path(i) == c_null_char .or. i > 1024) exit + fpath(i:i) = path(i) + i = i + 1 +end do + +fname = trim(fpath)//'/output.in' +open (newunit=u, file=trim(fname), status='old', action='read', iostat=ios) +if (ios /= 0) then + write (error_unit, '(a,a)') "error: read_output_settings: cannot open ", trim(fname) + error stop +end if + +call skip(u) +call get_int(u, flag_background) +call get_int(u, flag_emfield) +call get_int(u, flag_additional) +call get_int(u, flag_dispersion) +call skip(u) +call skip(u) +call get_int(u, flag_debug) +call skip(u) +call skip(u) + +num_quants = 8 +if (allocated(flag_quants)) deallocate (flag_quants) +allocate (flag_quants(num_quants)) +do k = 1, num_quants + call get_int(u, flag_quants(k)) +end do + +close (u) + +contains + + subroutine skip(unit) + integer, intent(in) :: unit + integer :: jos + read (unit, '(a)', iostat=jos) buf + if (jos /= 0) then + write (error_unit, '(a)') "error: read_output_settings: read error" + error stop + end if + end subroutine skip + + subroutine get_int(unit, val) + integer, intent(in) :: unit + integer, intent(out) :: val + integer :: jos + read (unit, '(a)', iostat=jos) buf + if (jos /= 0) then + write (error_unit, '(a)') "error: read_output_settings: read error" + error stop + end if + pos = index(buf, '#') + if (pos > 0) then + before = buf(1:pos - 1) + else + before = buf + end if + read (before, *) val + end subroutine get_int + +end subroutine read_output_settings + +!------------------------------------------------------------------------------ + +integer(c_int) function get_output_flag_background() bind(C, name="get_output_flag_background_") + use, intrinsic :: iso_c_binding, only: c_int + use output_data, only: flag_background + get_output_flag_background = flag_background +end function + +integer(c_int) function get_output_flag_emfield() bind(C, name="get_output_flag_emfield_") + use, intrinsic :: iso_c_binding, only: c_int + use output_data, only: flag_emfield + get_output_flag_emfield = flag_emfield +end function + +integer(c_int) function get_output_flag_additional() bind(C, name="get_output_flag_additional_") + use, intrinsic :: iso_c_binding, only: c_int + use output_data, only: flag_additional + get_output_flag_additional = flag_additional +end function + +integer(c_int) function get_output_flag_dispersion() bind(C, name="get_output_flag_dispersion_") + use, intrinsic :: iso_c_binding, only: c_int + use output_data, only: flag_dispersion + get_output_flag_dispersion = flag_dispersion +end function + +integer(c_int) function get_output_num_quants() bind(C, name="get_output_num_quants_") + use, intrinsic :: iso_c_binding, only: c_int + use output_data, only: num_quants + get_output_num_quants = num_quants +end function + +integer(c_int) function get_output_flag_quants(i) bind(C, name="get_output_flag_quants_") + use, intrinsic :: iso_c_binding, only: c_int + use output_data, only: flag_quants + integer(c_int), value :: i + get_output_flag_quants = flag_quants(i + 1) +end function diff --git a/KiLCA/core/settings.cpp b/KiLCA/core/settings.cpp deleted file mode 100644 index b2d8450f..00000000 --- a/KiLCA/core/settings.cpp +++ /dev/null @@ -1,34 +0,0 @@ -/*! \file settings.cpp - \brief The implementation of settings class. -*/ - -#include -#include -#include -#include - -#include "settings.h" - -/*******************************************************************/ - -void settings::read_settings (void) -{ - std::cout << ">> KiLCA: Reading settings from " << path2project << '\n'; - - as = new antenna; - as->read_settings (path2project); - copy_antenna_data_to_antenna_module_ (&as); - - bs = new back_sett; - bs->read_settings (path2project); - copy_background_data_to_background_module_ (&bs); - - os = new output_sett; - os->read_settings (path2project); - - es = new eigmode_sett; - es->read_settings (path2project); - std::cout << ">> KiLCA: Settings read successfully.\n"; -} - -/*******************************************************************/ diff --git a/KiLCA/core/settings.h b/KiLCA/core/settings.h deleted file mode 100644 index 52337670..00000000 --- a/KiLCA/core/settings.h +++ /dev/null @@ -1,67 +0,0 @@ -/*! \file settings.h - \brief The declaration of settings class. -*/ - -#ifndef SETTINGS_INCLUDE - -#define SETTINGS_INCLUDE - -#include - -#include "code_settings.h" - -#include "antenna.h" -#include "back_sett.h" -#include "output_sett.h" -#include "eigmode_sett.h" - -using namespace :: std; - -/*! \class settings - \brief The class contains all KiLCA settings. -*/ -class settings -{ -public: - char *path2project; //! Aggregates the four already-Fortran per-domain settings readers, formerly +!> the C++ settings class (settings.{h,cpp}). Per-instance handle (same +!> c_loc/transfer pattern as cond_profiles etc): core_data caches up to two +!> static settings instances (one per project-type path), each remembering +!> its own path2project, even though read_settings' actual side effect +!> (populating antenna_data/background/output_data/eigmode_sett_data module +!> state) is global, exactly as it already was for the C++ oracle - those +!> four reader modules were already global singletons before this port +!> began. +module kilca_settings_m + use, intrinsic :: iso_c_binding, only: c_intptr_t, c_char, c_ptr, c_loc, & + c_f_pointer, c_null_char + implicit none + private + + public :: settings_create_, settings_destroy_, settings_read_settings_ + public :: settings_get_path2project_ + + type :: settings_t + character(len=1024) :: path2project = '' + end type settings_t + + interface + subroutine read_antenna_settings(path) bind(C, name="read_antenna_settings_") + import :: c_char + character(kind=c_char), intent(in) :: path(*) + end subroutine read_antenna_settings + + subroutine read_background_settings(path) bind(C, name="read_background_settings_") + import :: c_char + character(kind=c_char), intent(in) :: path(*) + end subroutine read_background_settings + + subroutine read_output_settings(path) bind(C, name="read_output_settings_") + import :: c_char + character(kind=c_char), intent(in) :: path(*) + end subroutine read_output_settings + + subroutine read_eigmode_settings(path) bind(C, name="read_eigmode_settings_") + import :: c_char + character(kind=c_char), intent(in) :: path(*) + end subroutine read_eigmode_settings + end interface + +contains + + function settings_create_(path) result(handle) bind(C, name="settings_create_") + character(kind=c_char), intent(in) :: path(*) + integer(c_intptr_t) :: handle + type(settings_t), pointer :: sd + + allocate (sd) + sd%path2project = c_string_to_fortran(path) + handle = transfer(c_loc(sd), handle) + end function settings_create_ + + subroutine settings_destroy_(handle) bind(C, name="settings_destroy_") + integer(c_intptr_t), value :: handle + type(settings_t), pointer :: sd + + if (handle == 0_c_intptr_t) return + call handle_to_settings(handle, sd) + deallocate (sd) + end subroutine settings_destroy_ + + !> Mirrors settings::read_settings exactly: a status line, the four + !> domain readers in the same order, a completion line. + subroutine settings_read_settings_(handle) bind(C, name="settings_read_settings_") + integer(c_intptr_t), value :: handle + type(settings_t), pointer :: sd + character(kind=c_char), allocatable :: cpath(:) + + call handle_to_settings(handle, sd) + + write (*, '(a,a)') '>> KiLCA: Reading settings from ', trim(sd%path2project) + + cpath = to_cstr(sd%path2project) + + call read_antenna_settings(cpath) + call read_background_settings(cpath) + call read_output_settings(cpath) + call read_eigmode_settings(cpath) + + write (*, '(a)') '>> KiLCA: Settings read successfully.' + end subroutine settings_read_settings_ + + subroutine settings_get_path2project_(handle, buf) bind(C, name="settings_get_path2project_") + integer(c_intptr_t), value :: handle + character(kind=c_char), intent(out) :: buf(*) + type(settings_t), pointer :: sd + integer :: i, n + + call handle_to_settings(handle, sd) + n = len_trim(sd%path2project) + do i = 1, n + buf(i) = sd%path2project(i:i) + end do + buf(n + 1) = c_null_char + end subroutine settings_get_path2project_ + + subroutine handle_to_settings(handle, sd) + integer(c_intptr_t), value :: handle + type(settings_t), pointer, intent(out) :: sd + type(c_ptr) :: cp + cp = transfer(handle, cp) + call c_f_pointer(cp, sd) + end subroutine handle_to_settings + + function to_cstr(s) result(c) + character(len=*), intent(in) :: s + character(kind=c_char), allocatable :: c(:) + integer :: i, n + n = len_trim(s) + allocate (c(n + 1)) + do i = 1, n + c(i) = s(i:i) + end do + c(n + 1) = c_null_char + end function to_cstr + + function c_string_to_fortran(cstr) result(fstr) + character(kind=c_char), intent(in) :: cstr(*) + character(len=1024) :: fstr + integer :: i + fstr = '' + i = 0 + do + if (cstr(i + 1) == c_null_char .or. i >= 1024) exit + fstr(i + 1:i + 1) = cstr(i + 1) + i = i + 1 + end do + end function c_string_to_fortran + +end module kilca_settings_m diff --git a/KiLCA/core/shared.cpp b/KiLCA/core/shared.cpp deleted file mode 100644 index 8e87d33d..00000000 --- a/KiLCA/core/shared.cpp +++ /dev/null @@ -1,336 +0,0 @@ -/*! \file shared.cpp - \brief The implementation of some common and frequently used functions. -*/ - -#include -#include -#include -#include -#include - -#include "constants.h" -#include "shared.h" -#include "fortnum.h" - -/*******************************************************************/ - -extern "C" -{ -void dgesv_ (int *, int *, double *, int *, int *, double *, int *, int *); -} - -/*******************************************************************/ - -void * xmalloc (size_t size) -{ -register void *value = (void *) malloc (size); -if (!value) -{ - fprintf(stderr,"\nxmalloc: memory allocation failed: exit!"); - exit(1); -} -return value; -} - -/*******************************************************************/ - -void * xrealloc (void *ptr, size_t size) -{ -register void *value = (void *) realloc (ptr, size); -if (!value) -{ - fprintf(stderr,"\nxrealloc: memory reallocation failed: exit!"); - exit(1); -} -return value; -} - -/*******************************************************************/ - -int signum(double x) -{ -return (x<0.0) ? (-1):((x==0) ? 0:1); -} - -/*******************************************************************/ - -int compare_doubles (const void *a, const void *b) -{ -const double *da = (const double *) a; -const double *db = (const double *) b; - -return (*da > *db) - (*da < *db); -} - -/*******************************************************************/ - -void sort_index_doubles (size_t *perm, const double *x, size_t n) -{ -int ni = (int) n; -int *iperm = new int[ni]; - -fortnum_argsort (x, ni, iperm); - -for (int k=0; k 1) std::sort (perm+a, perm+b); - a = b; -} -} - -/*******************************************************************/ - -void binomial_coefficients (int N, double *BC) -{ -//computes C^k_n = n!/k!/(n-k)! coefficients for n=0..N, k=0..n -//fortran: C(n,k) = C^k_n; C: C[k][n] = C^k_n; -int k, n; -double tmp; - -for (n=0; n<=N; n++) -{ - tmp = 1.0; - BC[n] = tmp; //C^0_n - for (k=1; k<=n; k++) - { - tmp *= double(n-k+1)/double(k); - BC[n+k*(N+1)] = tmp; - } -} -} - -/*******************************************************************/ - -void binomial_coefficients_ (int N, double *BC) -{ -binomial_coefficients (N, BC); -} - -/*******************************************************************/ - -void Ckn (int N, double *BC) -{ -//computes C[k][n] = C^k_n = n!/k!/(n-k)! coefficients for n=0..N, k=0..n -int k, n; -double tmp; - -typedef double bincoeffs[N+1][N+1]; -bincoeffs &C = *((bincoeffs *)(BC)); - -for (n=0; n<=N; n++) -{ - tmp = 1.0; - C[0][n] = tmp; //C^0_n - for (k=1; k<=n; k++) - { - tmp *= double(n-k+1)/double(k); - C[k][n] = tmp; - } -} -} - -/*******************************************************************/ - -int calc_interp_polynom (int N, const double *x, const double *y, double *C) -{ -//calculates an interpolating polinom of degree N through the points: -//(x[0],y[0]),...,(x[N], y[N]) -//strores coefficients in array C for the later evaluation - -//the code is not checked!!! - -typedef double matrix[N+1][N+1]; - -matrix &A = *((matrix *)(new double[(N+1)*(N+1)])); - -int D = N+1, NRHS = 1, LDA = D, LDB = D, INFO; - -int *IPIV = new int[D]; - -int p, i; - -for (i=0; i<=N; i++) -{ - A[0][i] = 1.0; - A[1][i] = x[i]-x[0]; - for (p=2; p<=N; p++) //fortran matrix ordering - { - A[p][i] = A[p-1][i]*A[1][i]; - } - C[i] = y[i]; -} - -//linear system: -dgesv_ (&D, &NRHS, (double *)A, &LDA, IPIV, C, &LDB, &INFO); -if (INFO) -{ - fprintf (stderr, "\nerror: calc_interp_polynom: system failed: INFO=%d.", INFO); - return INFO; -} - -delete [] IPIV; -//delete [] A; -return 0; -} - -/*******************************************************************/ - -int eval_interp_polynom (int N, const double *x, const double *C, double r, int Dmin, int Dmax, double *R) -{ -if (rx[N]) -{ - fprintf (stderr, "\nerror: eval_interp_polynom: argument is outside the range: r=%le", r); - return 1; -} - -//the code is not finished!!! -fprintf (stderr, "\nerror: eval_interp_polynom: not implemented!"); - -return 0; -} - -/*******************************************************************/ - -void localizator (double x, double x0, double L, double *W) -{ -double dir, x1, x2, t, fac; - -dir = signum (x-x0); - -if (dir <= 0.0) -{ - x1 = x0 - L; - x2 = x1 + L/2.0; -} -else -{ - x2 = x0 + L; - x1 = x2 - L/2.0; -} - -if (dir > 0.0) -{ - t = (x-x1)/(x2-x1); - fac = 1.0; -} -else -{ - t = (x2-x)/(x2-x1); - fac = -1.0; -} - -double c1 = 2.0*pi, c2 = 1.414213562373095; - -if (t <= 0) -{ - W[0] = 1.0; - W[1] = 0.0; -} -else if (t >= 1.0) -{ - W[0] = 0.0; - W[1] = 0.0; -} -else -{ - W[0] = exp(-c1/(1.0-t)*exp(-c2/t)); - W[1] = - W[0]*c1/(1.0-t)*exp(-c2/t)*(1.0/(1.0-t)+c2/t/t)*fac/(x2-x1); -} -} - -/*******************************************************************/ - -void localizator_4_derivs (double x, double x0, double L, double *W) -{ -double dir, x1, x2, t, fac; - -dir = signum (x-x0); - -if (dir <= 0.0) -{ - x1 = x0 - L; - x2 = x1 + L/2.0; -} -else -{ - x2 = x0 + L; - x1 = x2 - L/2.0; -} - -if (dir > 0.0) -{ - t = (x-x1)/(x2-x1); - fac = 1.0; -} -else -{ - t = (x2-x)/(x2-x1); - fac = -1.0; -} - -double c1 = 2.0*pi, c2 = 1.414213562373095; -double E = 2.718281828459045235360287; - -if (t <= 1.0e-2) //0.0 - needed to avoid nans -{ - W[0] = 1.0; - W[1] = 0.0; - W[2] = 0.0; - W[3] = 0.0; - W[4] = 0.0; -} -else if (t >= 1.0 - 1.0e-2) //1.0 - needed to avoid nans -{ - W[0] = 0.0; - W[1] = 0.0; - W[2] = 0.0; - W[3] = 0.0; - W[4] = 0.0; -} -else -{ - W[0] = exp(-c1/(1.0-t)*exp(-c2/t)); - - W[1] = - c1/(1.0-t)*exp(-c2/t)*(1.0/(1.0-t)+c2/t/t); - W[1] *= W[0]*pow(fac/(x2-x1),1); - - W[2] = (c1*(c1*pow(c2 - c2*t + pow(t,2),2) + pow(E,c2/t)*(-1 + t)* - (pow(c2,2)*pow(-1 + t,2) + 2*pow(t,4) - 2*c2*t*(1 - 3*t + 2*pow(t,2)))))/(pow(E,(2*c2)/t)*pow(-1 + t,4)*pow(t,4)); - W[2] *= W[0]*pow(fac/(x2-x1),2); - - W[3] = (c1*(pow(c1,2)*pow(c2*(-1 + t) - pow(t,2),3) - 3*c1*pow(E,c2/t)* - (-1 + t)*(-(pow(c2,3)*pow(-1 + t,3)) + 2*pow(t,6) + - pow(c2,2)*pow(-1 + t,2)*t*(-2 + 5*t) - 2*c2*pow(t,3)*(1 - 4*t + 3*pow(t,2))) - - pow(E,(2*c2)/t)*pow(-1 + t,2)*(-(pow(c2,3)*pow(-1 + t,3)) + 6*pow(t,6) + - 3*pow(c2,2)*pow(-1 + t,2)*t*(-2 + 3*t) - 6*c2*pow(t,2)*(-1 + 4*t - 6*pow(t,2) - +3*pow(t,3)))))/(pow(E,(3*c2)/t)*pow(-1 + t,6)*pow(t,6)); - W[3] *= W[0]*pow(fac/(x2-x1),3); - - W[4] = (c1*(pow(c1,3)*pow(c2 - c2*t + pow(t,2), 4) + 6*pow(c1,2)*pow(E,c2/t)* - (-1 + t)*pow(c2 - c2*t + pow(t,2), 2)*(pow(c2,2)*pow(-1 + t,2) + 2*pow(t,4) - - 2*c2*t*(1 - 3*t + 2*pow(t,2))) + c1*pow(E,(2*c2)/t)*pow(-1 + t,2)* - (7*pow(c2,4)*pow(-1 + t,4) + 36*pow(t,8) - 4*pow(c2,3)*pow(-1 + t,3)*t* - (-9 + 16*t) + 12*pow(c2,2)*pow(-1 + t,2)*pow(t,2)*(3 - 12*t + 14*pow(t,2)) - - 24*c2*pow(t,4)*(-1 + 5*t - 10*pow(t,2) + 6*pow(t,3))) + pow(E,(3*c2)/t)* - pow(-1 + t,3)*(pow(c2,4)*pow(-1 + t,4) + 24*pow(t,8) - 4*pow(c2,3)* - pow(-1 + t,3)*t*(-3 + 4*t) + 12*pow(c2,2)*pow(-1 + t,2)* - pow(t,2)*(3 - 8*t + 6*pow(t,2)) - 24*c2*pow(t,3)*(1 - 5*t + 10*pow(t,2) - - 10*pow(t,3) + 4*pow(t,4)))))/(pow(E,(4*c2)/t)*pow(-1 + t,8)*pow(t,8)); - W[4] *= W[0]*pow(fac/(x2-x1),4); -} -} - -/*******************************************************************/ diff --git a/KiLCA/core/shared.h b/KiLCA/core/shared.h deleted file mode 100644 index b806ad87..00000000 --- a/KiLCA/core/shared.h +++ /dev/null @@ -1,53 +0,0 @@ -/*! \file shared.h - \brief Some common and frequently used functions declarations. -*/ - -#ifndef SHARED_INCLUDE - -#define SHARED_INCLUDE - -#include -#include -#include -#include - -//#if defined(__cplusplus) -//extern "C" { -//#endif - -void * xmalloc (size_t size); - -void * xrealloc (void *ptr, size_t size); - -int signum(double x); - -int compare_doubles (const void *a, const void *b); - -// Ascending index sort: perm[k] receives the index into x of the k-th -// smallest value (x[perm] nondecreasing). Wraps fortnum_argsort and adapts -// the int permutation to the size_t buffers used by the KiLCA callers. -void sort_index_doubles (size_t *perm, const double *x, size_t n); - -void binomial_coefficients (int N, double *BC); - -struct cmplx_number -{ - double re; - double im; -}; - -typedef struct cmplx_number cmplx; - -// #if defined(__cplusplus) -// } -// #endif - -extern "C" -{ -void binomial_coefficients_ (int N, double *BC); -void Ckn (int N, double *C); -void localizator (double x, double x0, double L, double *W); -void localizator_4_derivs (double x, double x0, double L, double *W); -} - -#endif diff --git a/KiLCA/core/shared_m.f90 b/KiLCA/core/shared_m.f90 new file mode 100644 index 00000000..c5e80853 --- /dev/null +++ b/KiLCA/core/shared_m.f90 @@ -0,0 +1,170 @@ +!> The live subset of core/shared.{h,cpp}'s common helpers. Deliberately +!> partial: xmalloc/xrealloc/compare_doubles/Ckn/calc_interp_polynom/ +!> eval_interp_polynom/localizator/localizator_4_derivs had zero live +!> callers anywhere in KiLCA or QL-Balance (verified by grep across all +!> C++, header and Fortran source files) and were dropped, matching this +!> port's established dead-code precedent. +!> +!> signum and sort_index_doubles keep C++ linkage (bind(C), no trailing +!> underscore) since their one remaining caller each is still C++ +!> (progs/main_eig_param.cpp, math/adapt_grid/adaptive_grid.cpp - both S8 +!> scope, not yet translated). +!> +!> binomial_coefficients is the live subset's odd one out: it is called +!> only by PRE-EXISTING legacy Fortran (flre/conductivity/kmatrices*.f90, +!> conduct_arrays*.f90) via implicit/external interface +!> (`call binomial_coefficients (%val(N), bico)`, no trailing underscore +!> in the source text) - gfortran mangles that call to the external +!> symbol "binomial_coefficients_". A free (non-module-contained) +!> subprogram below provides exactly that symbol, per this port's +!> established free-subprogram-vs-module-contained-procedure rule. +module kilca_shared_m + use, intrinsic :: iso_c_binding, only: c_double, c_int, c_size_t + use constants, only: dp + use fortnum_multiroot, only: argsort + implicit none + private + + public :: signum, sort_index_doubles, strtol_int + +contains + + !> Reproduces C's strtol(s, NULL, 10) exactly: skip leading whitespace, + !> an optional sign, then consume a run of decimal digits, stopping at + !> the first non-digit character (0 if no digits are found at all). + !> This is NOT the same as a clean "parse the whole string as an + !> integer, 0 on any failure" - the .in file readers throughout this + !> port's oracle (read_line_2get_int_ in io/inout.cpp, and every + !> zone-settings/eigmode-settings reader built on the same convention) + !> use exactly this truncating strtol behavior, so genuinely malformed- + !> looking input like "1.00e+05" for an integer field is not an error + !> in the oracle - it silently becomes 1 (the leading digit run before + !> the decimal point), and this port's Fortran translations must + !> reproduce that silent truncation bit-for-bit rather than "properly" + !> parsing the full numeric literal or defaulting to 0. + function strtol_int(s) result(val) + character(len=*), intent(in) :: s + integer :: val + integer :: i, n, sgn + logical :: found_digit + + n = len(s) + i = 1 + val = 0 + sgn = 1 + found_digit = .false. + + do while (i <= n) + if (s(i:i) /= ' ' .and. s(i:i) /= achar(9)) exit + i = i + 1 + end do + + if (i <= n) then + if (s(i:i) == '-') then + sgn = -1 + i = i + 1 + else if (s(i:i) == '+') then + i = i + 1 + end if + end if + + do while (i <= n) + if (s(i:i) < '0' .or. s(i:i) > '9') exit + val = val*10 + (iachar(s(i:i)) - iachar('0')) + found_digit = .true. + i = i + 1 + end do + + if (.not. found_digit) val = 0 + val = val*sgn + end function strtol_int + + function signum(x) result(s) bind(C, name="signum") + real(c_double), value :: x + integer(c_int) :: s + if (x < 0.0_c_double) then + s = -1 + else if (x == 0.0_c_double) then + s = 0 + else + s = 1 + end if + end function signum + + !> Ascending index sort: perm(k) receives the (0-based) index into x of + !> the k-th smallest value. Uses fortnum_multiroot's native argsort + !> (heapsort, 1-based) then converts to 0-based for the still-C++ + !> caller. argsort's heapsort is not stable; the conductivity grid + !> shares zone-boundary nodes (duplicated x), so the sort must be + !> deterministic for the spline to be well-defined - the oracle's own + !> fixup (break exact-key ties by ascending original index) is + !> reproduced verbatim below. + subroutine sort_index_doubles(perm, xarr, n) bind(C, name="sort_index_doubles") + integer(c_size_t), value :: n + real(c_double), intent(in) :: xarr(0:n - 1) + integer(c_size_t), intent(out) :: perm(0:n - 1) + integer, allocatable :: fperm(:) + integer :: nn, i + integer(c_size_t) :: a, b + + nn = int(n) + allocate (fperm(nn)) + call argsort(xarr, fperm) + do i = 1, nn + perm(i - 1) = int(fperm(i) - 1, c_size_t) + end do + deallocate (fperm) + + a = 0 + do while (a < n) + b = a + 1 + do while (b < n) + if (xarr(perm(b)) /= xarr(perm(a))) exit + b = b + 1 + end do + if (b - a > 1) call sort_ascending_size_t(perm(a:b - 1)) + a = b + end do + end subroutine sort_index_doubles + + !> Small-range insertion sort (std::sort's effect on a tie-block here + !> is always small: at most a handful of coincident zone-boundary + !> nodes), ascending by raw index value, matching std::sort(perm+a, + !> perm+b) with the default operator< on size_t. + subroutine sort_ascending_size_t(arr) + integer(c_size_t), intent(inout) :: arr(:) + integer :: i, j + integer(c_size_t) :: key + do i = 2, size(arr) + key = arr(i) + j = i - 1 + do while (j >= 1) + if (arr(j) <= key) exit + arr(j + 1) = arr(j) + j = j - 1 + end do + arr(j + 1) = key + end do + end subroutine sort_ascending_size_t + +end module kilca_shared_m + +!> Free (non-module-contained) subprogram: see the module banner above for +!> why this cannot live inside kilca_shared_m's `contains` block. +subroutine binomial_coefficients(N, BC) + use, intrinsic :: iso_c_binding, only: c_int, c_double + implicit none + integer(c_int), value :: N + real(c_double), intent(out) :: BC(0:N, 0:N) + integer :: k, n_idx + real(c_double) :: tmp + + do n_idx = 0, N + tmp = 1.0_c_double + BC(n_idx, 0) = tmp + do k = 1, n_idx + tmp = tmp*real(n_idx - k + 1, c_double)/real(k, c_double) + BC(n_idx, k) = tmp + end do + end do +end subroutine binomial_coefficients diff --git a/KiLCA/core/typedefs.h b/KiLCA/core/typedefs.h deleted file mode 100644 index d1221800..00000000 --- a/KiLCA/core/typedefs.h +++ /dev/null @@ -1,9 +0,0 @@ -#ifndef TYPE_DEFS - -#define TYPE_DEFS - -typedef unsigned char uchar; - -typedef signed char schar; - -#endif diff --git a/KiLCA/eigmode/calc_eigmode.cpp b/KiLCA/eigmode/calc_eigmode.cpp deleted file mode 100644 index 2e556b8a..00000000 --- a/KiLCA/eigmode/calc_eigmode.cpp +++ /dev/null @@ -1,247 +0,0 @@ -/*! \file calc_eigmode.cpp - \brief The implementation of the functions declared in calc_eigmode.h -*/ - -#include "eigmode_sett.h" -#include "calc_eigmode.h" -#include "inout.h" -#include "mode.h" - -#include "fortnum.h" - -/**********************************************************************************/ - -// fortnum_vector_fn residual: x = (Re f, Im f), out = (Re det, Im det). -// Replaces the gsl_vector-based eval_det; the multiroot solver builds the -// Jacobian internally by central differences (the former eval_jac). -void eval_det (int n, const double *x, double *f, void *params) -{ -(void) n; - -int ind = ((det_params *) params)->ind; -int m = ((det_params *) params)->m; -int nn = ((det_params *) params)->n; - -core_data *cd = ((det_params *) params)->cd; - -const double fre = x[0]; -const double fim = x[1]; - -complex olab = 2.0*pi*(fre + I*fim); - -cd->mda[ind] = new mode_data (m, nn, olab, (const settings *)cd->sd, (const background *)cd->bp); - -cd->mda[ind]->calc_all_mode_data (); - -complex det = (cd->mda[ind])->wd->det; - -//for debugging: -FILE *out; -if (!(out = fopen ("det.dat", "a"))) -{ - fprintf (stderr, "\nFailed to open file %s\a\n", "det.dat"); -} - -fprintf (out, "\n%.20le %.20le\t%.20le %.20le", fre, fim, real(det), imag(det)); - -fclose (out); -//end debugging - -f[0] = real(det); -f[1] = imag(det); - -//clean up: -delete cd->mda[ind]; -cd->mda[ind] = NULL; -clear_all_data_in_mode_data_module_ (); //clean up fortran module data -} - -/**********************************************************************************/ - -int find_det_zeros (int ind, int m, int n, core_data *cd) -{ -const eigmode_sett *es = cd->sd->es; - -//output file: -char *full_name = new char[1024]; -sprintf (full_name, "%s%s", cd->sd->path2project, es->fname); - -FILE *out; -if (!(out = fopen (full_name, "w"))) -{ - fprintf (stderr, "\nFailed to open file %s\a\n", full_name); -} - -int status = 0; - -const int N = 2; - -det_params p = {ind, m, n, es->delta, cd}; - -double x_init[2]; -double x_root[2]; - -complex center, quad1, quad2; -double radius; - -fprintf (out, "%%Re(f)\t\t\tIm(f)\t\t\tRe(det)\t\t\tIm(det)"); -fclose (out); - -int k; -for (k=es->kmin; k<=es->kmax; k++) -{ - if (!(out = fopen (full_name, "a"))) - { - fprintf (stderr, "\nFailed to open file %s\a\n", full_name); - } - - x_init[0] = real (es->fstart[k]); - x_init[1] = imag (es->fstart[k]); - - // fortnum_multiroot_hybrid does a hybrid Newton solve building the Jacobian - // by central differences, matching the former gsl_multiroot_fdfsolver - // (hybridsj) usage with the finite-difference eval_jac. The residual and - // step-size tolerances reuse the eigmode-options eps values. - status = fortnum_multiroot_hybrid (&eval_det, N, x_init, es->eps_abs, - es->eps_res, (int) 1e6, x_root, &p); - - double det_out[2]; - eval_det (N, x_root, det_out, &p); - - fprintf (out, "\n%.20le %.20le\t%.20le %.20le", x_root[0], x_root[1], det_out[0], det_out[1]); - - fprintf (out, "\n%%status = %d", status); - - //check if it is really root: - if (es->test_roots == 1) - { - radius = 1.0e1; - - center = x_root[0] + I*x_root[1]; - - quad1 = calc_circle_integral (center, radius, inv_det, &p); - - center += 5.0*radius*(1.0+I); - - quad2 = calc_circle_integral (center, radius, inv_det, &p); - - fprintf (stdout, "\nquad1 = %.20le %.20le\tquad2 = %.20le %.20le", - real(quad1), imag(quad1), real(quad2), imag(quad2)); - - fprintf (out, "\n%%quad1 = %.20le %.20le\tquad2 = %.20le %.20le\terr = %.20le", - real(quad1), imag(quad1), real(quad2), imag(quad2), abs(quad1/quad2)); - } - fflush (out); - fclose (out); -} - -delete [] full_name; - -return status; -} - -/**********************************************************************************/ - -complex calc_circle_integral(complex center, double radius, cmplx_func F, void *params) -{ -int k, N = 100; -double dphi = 2.0*pi/N; -complex expon, res; - -res = O; -for (k=0; k inv_det(complex z, void *params) -{ -double x[2]; -double f[2]; - -x[0] = real(z); -x[1] = imag(z); - -eval_det (2, x, f, params); - -complex det = f[0] + I*f[1]; - -return E/det; -} - -/**********************************************************************************/ - -complex test_func(complex z, void *params) -{ -return exp(z)/(z-I)/(z-I)/(z-I); -//return (E+I)/z; -} - -/**********************************************************************************/ - -int loop_over_frequences (int ind, int m, int n, core_data *cd) -{ -const eigmode_sett *es = cd->sd->es; - -//output file: -char *full_name = new char[1024]; -sprintf (full_name, "%s%s", cd->sd->path2project, es->fname); - -FILE *out; -if (!(out = fopen (full_name, "w"))) -{ - fprintf (stderr, "\nFailed to open file %s\a\n", full_name); -} - -delete [] full_name; - -fprintf (out, "%%iter\tRe(f)\t\t\tIm(f)\t\t\tRe(det)\t\t\tIm(det)"); - -for (int i=0; irdim; i++) -{ - double fre = es->rfmin + i*(es->rfmax - es->rfmin)/max(es->rdim-1, 1); - - for (int k=0; kidim; k++) - { - double fim = es->ifmin + k*(es->ifmax - es->ifmin)/max(es->idim-1, 1); - - complex olab = 2.0*pi*(fre + I*fim); - - cd->mda[ind] = new mode_data (m, n, olab, (const settings *)cd->sd, (const background *)cd->bp); - - cd->mda[ind]->calc_all_mode_data (); - - fprintf (out, "\n%6u\t%.20le %.20le\t%.20le %.20le", i*(es->idim)+k, fre, fim, - real(cd->mda[ind]->wd->det), imag(cd->mda[ind]->wd->det)); - fflush (out); - - delete cd->mda[ind]; - cd->mda[ind] = NULL; - clear_all_data_in_mode_data_module_ (); - } -} -fclose (out); -return 0; -} - -/**********************************************************************************/ - -void calc_det (double *freq, double *absdet, void *params) -{ -double x[2]; -double f[2]; - -x[0] = 0.0e0; -x[1] = *freq; - -eval_det (2, x, f, params); - -*absdet = f[1]; //imaginary part -} - -/**********************************************************************************/ diff --git a/KiLCA/eigmode/calc_eigmode.h b/KiLCA/eigmode/calc_eigmode.h deleted file mode 100644 index 148b4e83..00000000 --- a/KiLCA/eigmode/calc_eigmode.h +++ /dev/null @@ -1,44 +0,0 @@ -/*! \file calc_eigmode.h - \brief The declarations of functions used to find eigenmode. -*/ - -#include - -#include "core.h" -#include "mode.h" - -/**********************************************************************************/ - -typedef complex (*cmplx_func)(complex, void *params); - -/**********************************************************************************/ - -struct det_params -{ - int ind; - int m; - int n; - double delta; - core_data *cd; -}; - -/**********************************************************************************/ - -// Residual on the fortnum_vector_fn ABI: x = (Re f, Im f), f = (Re det, Im det). -void eval_det (int n, const double *x, double *f, void *params); - -int find_det_zeros (int ind, int m, int n, core_data *cd); - -complex calc_circle_integral(complex center, double radius, cmplx_func inv_det, void *params); - -complex inv_det(complex z, void *params); - -complex test_func(complex z, void *params); - -int loop_over_frequences (int ind, int m, int n, core_data *cd); - -void calc_det (double *freq, double *absdet, void *params); - -int find_eigmodes (int ind, int m, int n, core_data *cd); - -/**********************************************************************************/ diff --git a/KiLCA/eigmode/eigmode_sett.cpp b/KiLCA/eigmode/eigmode_sett.cpp deleted file mode 100644 index 9f21dbc8..00000000 --- a/KiLCA/eigmode/eigmode_sett.cpp +++ /dev/null @@ -1,140 +0,0 @@ -/*! \file eigmode_sett.cpp - \brief The implementation of eigmode_sett class. -*/ - -#include -#include -#include -#include - -#include "eigmode_sett.h" -#include "inout.h" - -/*****************************************************************************/ - -void eigmode_sett::read_settings (char *path) -{ -char *file_set = new char[1024]; - -sprintf (file_set, "%s/eigmode.in", path); - -FILE *in; - -if ((in=fopen (file_set, "r"))==NULL) -{ - fprintf(stderr, "\nerror: read_settings: failed to open file %s\a\n", file_set); - exit(0); -} - -char *str_buf = new char[1024]; //str buffer - -//Output: -read_line_2skip_it (in, &str_buf); -fname = new char[1024]; -read_line_2get_string (in, &(fname)); -read_line_2skip_it (in, &str_buf); - -//frequency scan or root search: -read_line_2skip_it (in, &str_buf); -read_line_2get_int (in, &(search_flag)); -read_line_2skip_it (in, &str_buf); - -//frequency grid: -read_line_2skip_it (in, &str_buf); -read_line_2get_int (in, &(rdim)); -read_line_2get_double (in, &(rfmin)); -read_line_2get_double (in, &(rfmax)); -read_line_2get_int (in, &(idim)); -read_line_2get_double (in, &(ifmin)); -read_line_2get_double (in, &(ifmax)); -read_line_2skip_it (in, &str_buf); - -//Stopping criteria: -read_line_2skip_it (in, &str_buf); -read_line_2get_int (in, &(stop_flag)); -read_line_2get_double (in, &(eps_res)); -read_line_2get_double (in, &(eps_abs)); -read_line_2get_double (in, &(eps_rel)); -read_line_2skip_it (in, &str_buf); - -//For derivative: -read_line_2skip_it (in, &str_buf); -read_line_2get_double (in, &(delta)); -read_line_2skip_it (in, &str_buf); - -//For testing: -read_line_2skip_it (in, &str_buf); -read_line_2get_int (in, &(test_roots)); -read_line_2get_int (in, &(flag_debug)); -read_line_2skip_it (in, &str_buf); - -// ZerSol parameters: -read_line_2skip_it (in, &str_buf); -read_line_2get_int (in, &(n_zeros)); -read_line_2get_int (in, &(use_winding)); -read_line_2skip_it (in, &str_buf); - -//Starting points: -read_line_2skip_it (in, &str_buf); -read_line_2get_int (in, &(Nguess)); -read_line_2get_int (in, &(kmin)); -read_line_2get_int (in, &(kmax)); -read_line_2skip_it (in, &str_buf); - -fstart = new complex[Nguess]; - -int k; - -read_line_2skip_it (in, &str_buf); - -for (k=0; k - -using namespace std; - -/*****************************************************************************/ - -/*! \class eigmode_sett - \brief Class represents set of settings for eigenmode search. -*/ -class eigmode_sett -{ -public: - char *fname; //! *fstart; - - ///number of zeros to be found - int n_zeros; - - ///flag specifies whether to use winding number evaluation or not - int use_winding; - -public: - //eigmode_sett (void); - - ~eigmode_sett (void) - { - delete [] fname; - delete [] fstart; - } - - void read_settings (char *path); - void print_settings (); -}; - -/*****************************************************************************/ - -#endif diff --git a/KiLCA/eigmode/eigmode_sett_m.f90 b/KiLCA/eigmode/eigmode_sett_m.f90 new file mode 100644 index 00000000..ba58f8e0 --- /dev/null +++ b/KiLCA/eigmode/eigmode_sett_m.f90 @@ -0,0 +1,306 @@ +!> Eigenmode search settings, formerly the C++ eigmode_sett class. The Fortran +!> eigmode_sett_data module parses eigmode.in and serves the fields to the +!> remaining C++ via bind(C) getters. Layout matches eigmode_sett::read_settings +!> exactly. +module eigmode_sett_data + +use constants, only: dp, dpc + +character(len=1024) :: fname +integer :: search_flag +integer :: rdim +real(dp) :: rfmin, rfmax +integer :: idim +real(dp) :: ifmin, ifmax +integer :: stop_flag +real(dp) :: eps_res, eps_abs, eps_rel +real(dp) :: delta +integer :: test_roots +integer :: flag_debug +integer :: Nguess +integer :: kmin, kmax +complex(dpc), dimension(:), allocatable :: fstart +integer :: n_zeros +integer :: use_winding + +end module + +!------------------------------------------------------------------------------ + +subroutine read_eigmode_settings(path) bind(C, name="read_eigmode_settings_") + +use, intrinsic :: iso_c_binding, only: c_char, c_null_char +use, intrinsic :: iso_fortran_env, only: error_unit +use eigmode_sett_data +use kilca_shared_m, only: strtol_int + +character(kind=c_char), dimension(*), intent(in) :: path + +character(len=1024) :: fpath, fullname, line, before +integer :: i, u, ios, k + +fpath = '' +i = 1 +do + if (path(i) == c_null_char .or. i > 1024) exit + fpath(i:i) = path(i) + i = i + 1 +end do + +fullname = trim(fpath)//'/eigmode.in' +open (newunit=u, file=trim(fullname), status='old', action='read', iostat=ios) +if (ios /= 0) then + write (error_unit, '(a,a)') "error: read_eigmode_settings: cannot open ", trim(fullname) + error stop +end if + +call skip(u) +call value_before_hash(u, before); fname = trim(adjustl(before)) +call skip(u) + +call skip(u) +call value_before_hash(u, before); call parse_int(before, search_flag) +call skip(u) + +call skip(u) +call value_before_hash(u, before); call parse_int(before, rdim) +call value_before_hash(u, before); call parse_real(before, rfmin) +call value_before_hash(u, before); call parse_real(before, rfmax) +call value_before_hash(u, before); call parse_int(before, idim) +call value_before_hash(u, before); call parse_real(before, ifmin) +call value_before_hash(u, before); call parse_real(before, ifmax) +call skip(u) + +call skip(u) +call value_before_hash(u, before); call parse_int(before, stop_flag) +call value_before_hash(u, before); call parse_real(before, eps_res) +call value_before_hash(u, before); call parse_real(before, eps_abs) +call value_before_hash(u, before); call parse_real(before, eps_rel) +call skip(u) + +call skip(u) +call value_before_hash(u, before); call parse_real(before, delta) +call skip(u) + +call skip(u) +call value_before_hash(u, before); call parse_int(before, test_roots) +call value_before_hash(u, before); call parse_int(before, flag_debug) +call skip(u) + +call skip(u) +call value_before_hash(u, before); call parse_int(before, n_zeros) +call value_before_hash(u, before); call parse_int(before, use_winding) +call skip(u) + +call skip(u) +call value_before_hash(u, before); call parse_int(before, Nguess) +call value_before_hash(u, before); call parse_int(before, kmin) +call value_before_hash(u, before); call parse_int(before, kmax) +call skip(u) + +if (allocated(fstart)) deallocate (fstart) +allocate (fstart(0:Nguess - 1)) + +call skip(u) +do k = 0, Nguess - 1 + call value_before_hash(u, before) + call parse_complex(before, fstart(k)) +end do + +close (u) + +contains + + subroutine skip(unit) + integer, intent(in) :: unit + integer :: jos + read (unit, '(a)', iostat=jos) line + if (jos /= 0) then + write (error_unit, '(a)') "error: read_eigmode_settings: read error" + error stop + end if + end subroutine skip + + subroutine value_before_hash(unit, out) + integer, intent(in) :: unit + character(len=*), intent(out) :: out + character(len=1024) :: buf + integer :: pos, jos + read (unit, '(a)', iostat=jos) buf + if (jos /= 0) then + write (error_unit, '(a)') "error: read_eigmode_settings: read error" + error stop + end if + pos = index(buf, '#') + if (pos > 0) then + out = buf(1:pos - 1) + else + out = buf + end if + end subroutine value_before_hash + + !> Mirrors read_line_2get_int_'s exact C strtol(s, NULL, 10) semantics + !> (see kilca_shared_m::strtol_int): eigmode_sett_data's own file + !> parsing must tolerate the same malformed/misaligned input the + !> oracle's read_line_2get_int does, rather than aborting - a real + !> eigmode.in in the wild (e.g. this port's golden-record fixture) is + !> missing the "ZerSol parameters" section (n_zeros/use_winding) that + !> read_settings expects, which shifts every subsequent field by two + !> lines; the oracle silently continues with garbage-but-defined + !> values (confirmed against the pristine C++ build: n_zeros=4, + !> use_winding=0, Nguess=0, so the fstart-reading loop below never + !> executes) instead of crashing - matching that exactly is more + !> faithful than erroring out on input the oracle happens to tolerate. + subroutine parse_int(s, val) + character(len=*), intent(in) :: s + integer, intent(out) :: val + val = strtol_int(s) + end subroutine parse_int + + subroutine parse_real(s, val) + character(len=*), intent(in) :: s + real(dp), intent(out) :: val + integer :: jos + read (s, *, iostat=jos) val + if (jos /= 0) val = 0.0_dp + end subroutine parse_real + + subroutine parse_complex(s, val) + character(len=*), intent(in) :: s + complex(dpc), intent(out) :: val + integer :: jos + read (s, *, iostat=jos) val + if (jos /= 0) val = (0.0_dp, 0.0_dp) + end subroutine parse_complex + +end subroutine read_eigmode_settings + +!------------------------------------------------------------------------------ + +integer(c_int) function get_eigmode_search_flag() bind(C, name="get_eigmode_search_flag_") + use, intrinsic :: iso_c_binding, only: c_int + use eigmode_sett_data, only: search_flag + get_eigmode_search_flag = search_flag +end function + +real(c_double) function get_eigmode_delta() bind(C, name="get_eigmode_delta_") + use, intrinsic :: iso_c_binding, only: c_double + use eigmode_sett_data, only: delta + get_eigmode_delta = delta +end function + +real(c_double) function get_eigmode_rfmin() bind(C, name="get_eigmode_rfmin_") + use, intrinsic :: iso_c_binding, only: c_double + use eigmode_sett_data, only: rfmin + get_eigmode_rfmin = rfmin +end function + +real(c_double) function get_eigmode_rfmax() bind(C, name="get_eigmode_rfmax_") + use, intrinsic :: iso_c_binding, only: c_double + use eigmode_sett_data, only: rfmax + get_eigmode_rfmax = rfmax +end function + +real(c_double) function get_eigmode_ifmin() bind(C, name="get_eigmode_ifmin_") + use, intrinsic :: iso_c_binding, only: c_double + use eigmode_sett_data, only: ifmin + get_eigmode_ifmin = ifmin +end function + +real(c_double) function get_eigmode_ifmax() bind(C, name="get_eigmode_ifmax_") + use, intrinsic :: iso_c_binding, only: c_double + use eigmode_sett_data, only: ifmax + get_eigmode_ifmax = ifmax +end function + +integer(c_int) function get_eigmode_rdim() bind(C, name="get_eigmode_rdim_") + use, intrinsic :: iso_c_binding, only: c_int + use eigmode_sett_data, only: rdim + get_eigmode_rdim = rdim +end function + +integer(c_int) function get_eigmode_idim() bind(C, name="get_eigmode_idim_") + use, intrinsic :: iso_c_binding, only: c_int + use eigmode_sett_data, only: idim + get_eigmode_idim = idim +end function + +integer(c_int) function get_eigmode_n_zeros() bind(C, name="get_eigmode_n_zeros_") + use, intrinsic :: iso_c_binding, only: c_int + use eigmode_sett_data, only: n_zeros + get_eigmode_n_zeros = n_zeros +end function + +integer(c_int) function get_eigmode_use_winding() bind(C, name="get_eigmode_use_winding_") + use, intrinsic :: iso_c_binding, only: c_int + use eigmode_sett_data, only: use_winding + get_eigmode_use_winding = use_winding +end function + +integer(c_int) function get_eigmode_Nguess() bind(C, name="get_eigmode_Nguess_") + use, intrinsic :: iso_c_binding, only: c_int + use eigmode_sett_data, only: Nguess + get_eigmode_Nguess = Nguess +end function + +integer(c_int) function get_eigmode_kmin() bind(C, name="get_eigmode_kmin_") + use, intrinsic :: iso_c_binding, only: c_int + use eigmode_sett_data, only: kmin + get_eigmode_kmin = kmin +end function + +integer(c_int) function get_eigmode_kmax() bind(C, name="get_eigmode_kmax_") + use, intrinsic :: iso_c_binding, only: c_int + use eigmode_sett_data, only: kmax + get_eigmode_kmax = kmax +end function + +integer(c_int) function get_eigmode_test_roots() bind(C, name="get_eigmode_test_roots_") + use, intrinsic :: iso_c_binding, only: c_int + use eigmode_sett_data, only: test_roots + get_eigmode_test_roots = test_roots +end function + +real(c_double) function get_eigmode_eps_abs() bind(C, name="get_eigmode_eps_abs_") + use, intrinsic :: iso_c_binding, only: c_double + use eigmode_sett_data, only: eps_abs + get_eigmode_eps_abs = eps_abs +end function + +real(c_double) function get_eigmode_eps_rel() bind(C, name="get_eigmode_eps_rel_") + use, intrinsic :: iso_c_binding, only: c_double + use eigmode_sett_data, only: eps_rel + get_eigmode_eps_rel = eps_rel +end function + +real(c_double) function get_eigmode_eps_res() bind(C, name="get_eigmode_eps_res_") + use, intrinsic :: iso_c_binding, only: c_double + use eigmode_sett_data, only: eps_res + get_eigmode_eps_res = eps_res +end function + +subroutine get_eigmode_fname(out) bind(C, name="get_eigmode_fname_") + use, intrinsic :: iso_c_binding, only: c_char, c_null_char + use eigmode_sett_data, only: fname + character(kind=c_char), dimension(*), intent(out) :: out + integer :: i, n + n = len_trim(fname) + do i = 1, n + out(i) = fname(i:i) + end do + out(n + 1) = c_null_char +end subroutine + +real(c_double) function get_eigmode_fstart_re(k) bind(C, name="get_eigmode_fstart_re_") + use, intrinsic :: iso_c_binding, only: c_int, c_double + use eigmode_sett_data, only: fstart + integer(c_int), value :: k + get_eigmode_fstart_re = real(fstart(k)) +end function + +real(c_double) function get_eigmode_fstart_im(k) bind(C, name="get_eigmode_fstart_im_") + use, intrinsic :: iso_c_binding, only: c_int, c_double + use eigmode_sett_data, only: fstart + integer(c_int), value :: k + get_eigmode_fstart_im = aimag(fstart(k)) +end function diff --git a/KiLCA/eigmode/eigmode_solve_m.f90 b/KiLCA/eigmode/eigmode_solve_m.f90 new file mode 100644 index 00000000..49ce07dc --- /dev/null +++ b/KiLCA/eigmode/eigmode_solve_m.f90 @@ -0,0 +1,543 @@ +!> Eigenmode root-search strategies, formerly eigmode/calc_eigmode.cpp and +!> eigmode/find_eigmodes.cpp. Three runtime-selected paths, dispatched by +!> get_eigmode_search_flag_ from core_data_m's +!> core_data_calc_and_set_mode_dependent_eigmode_: +!> +!> find_det_zeros - multi-start hybrid Newton solve via fortnum's +!> fortnum_multiroot_hybrid, with an optional winding +!> number sanity check (calc_circle_integral/inv_det). +!> loop_over_frequences - brute-force 2D (re f, im f) determinant table dump. +!> find_eigmodes - reliable zeros search driving the vendored ZerSol +!> C++ library through its extern "C" wrapper +!> (zersolc.h); the templated zerosolver.hpp stays C++. +!> +!> The shared determinant evaluation (the oracle's eval_det and templated +!> determinant, near-identical bodies) lives in compute_det; the two +!> callback ABIs (fortnum_vector_fn and ZerSol's complex_function) are thin +!> bind(C) shims over eval_determinant_core. +module kilca_eigmode_solve_m + use, intrinsic :: iso_c_binding, only: c_int, c_double, c_double_complex, & + c_intptr_t, c_ptr, c_funptr, c_char, c_null_char, c_loc, c_funloc, & + c_f_pointer, c_null_funptr + use, intrinsic :: iso_fortran_env, only: output_unit + use constants, only: dp, pi, im + use eigmode_sett_data, only: es_fname => fname, es_rdim => rdim, & + es_idim => idim, es_rfmin => rfmin, es_rfmax => rfmax, & + es_ifmin => ifmin, es_ifmax => ifmax, es_eps_res => eps_res, & + es_eps_abs => eps_abs, es_eps_rel => eps_rel, es_delta => delta, & + es_test_roots => test_roots, es_nguess => Nguess, es_kmin => kmin, & + es_kmax => kmax, es_fstart => fstart, es_n_zeros => n_zeros, & + es_use_winding => use_winding + use kilca_core_data_m, only: core_data_get_sd_, core_data_get_bp_, & + core_data_set_mda_element_, core_data_get_mda_element_ + use kilca_settings_m, only: settings_get_path2project_ + use kilca_mode_data_m, only: mode_data_create_, mode_data_destroy_, & + mode_data_calc_all_mode_data_, mode_data_get_wd_ + use kilca_wave_data_m, only: wave_data_get_det_re, wave_data_get_det_im + implicit none + private + + public :: find_det_zeros, loop_over_frequences, find_eigmodes + public :: calc_det + + !> Mirrors the C struct det_params { int ind, m, n; double delta; + !> intptr_t cd; } field-for-field. Field order and interoperable kinds + !> must match the C layout exactly. delta is carried for layout fidelity + !> but read by neither callback (the oracle never read it either). + type, bind(C) :: det_params_t + integer(c_int) :: ind + integer(c_int) :: m + integer(c_int) :: n + real(c_double) :: delta + integer(c_intptr_t) :: cd + end type det_params_t + + interface + !> Legacy free Fortran subroutine in mode/mode_m.f90 (single trailing + !> underscore), not a module procedure - declared bind(C) here. + subroutine clear_all_data_in_mode_data_module() & + bind(C, name="clear_all_data_in_mode_data_module_") + end subroutine clear_all_data_in_mode_data_module + + !> fortnum multidimensional hybrid Newton solve, F(x)=0 in R^n. fdf is + !> the residual-only callback (fortnum_vector_fn); the wrapper builds + !> the Jacobian by central differences. + function fortnum_multiroot_hybrid(fdf, n, x0, xtol, ftol, max_iter, x, ctx) & + result(stat) bind(C, name="fortnum_multiroot_hybrid") + import :: c_int, c_double, c_funptr, c_ptr + type(c_funptr), value :: fdf + integer(c_int), value :: n + real(c_double), intent(in) :: x0(*) + real(c_double), value :: xtol, ftol + integer(c_int), value :: max_iter + real(c_double), intent(out) :: x(*) + type(c_ptr), value :: ctx + integer(c_int) :: stat + end function fortnum_multiroot_hybrid + + !> ZerSol extern "C" wrapper (math/zersol-0.0.0/src/zersolc.h), + !> already specialized to _Real = double. + function create_solver(f, df, data, description, xmin, xmax, ymin, ymax) & + result(solver) bind(C, name="create_solver") + import :: c_funptr, c_ptr, c_char, c_double + type(c_funptr), value :: f, df + type(c_ptr), value :: data + character(kind=c_char), intent(in) :: description(*) + real(c_double), value :: xmin, xmax, ymin, ymax + type(c_ptr) :: solver + end function create_solver + + function find_zeros(solver, n, z, v, n_zeros) result(stat) & + bind(C, name="find_zeros") + import :: c_ptr, c_int, c_double_complex + type(c_ptr), value :: solver + integer(c_int), value :: n + complex(c_double_complex), intent(out) :: z(*), v(*) + integer(c_int), intent(out) :: n_zeros + integer(c_int) :: stat + end function find_zeros + + subroutine print_status(solver, file_name) bind(C, name="print_status") + import :: c_ptr, c_char + type(c_ptr), value :: solver + character(kind=c_char), intent(in) :: file_name(*) + end subroutine print_status + + subroutine print_dump(solver, file_name) bind(C, name="print_dump") + import :: c_ptr, c_char + type(c_ptr), value :: solver + character(kind=c_char), intent(in) :: file_name(*) + end subroutine print_dump + + subroutine free_solver(solver) bind(C, name="free_solver") + import :: c_ptr + type(c_ptr), value :: solver + end subroutine free_solver + + subroutine set_nd_method(solver, method) bind(C, name="set_nd_method") + import :: c_ptr, c_int + type(c_ptr), value :: solver + integer(c_int), value :: method + end subroutine set_nd_method + + subroutine set_nd_step(solver, h) bind(C, name="set_nd_step") + import :: c_ptr, c_double + type(c_ptr), value :: solver + real(c_double), value :: h + end subroutine set_nd_step + + subroutine set_min_rec_lev(solver, min_rec_lev) bind(C, name="set_min_rec_lev") + import :: c_ptr, c_int + type(c_ptr), value :: solver + integer(c_int), value :: min_rec_lev + end subroutine set_min_rec_lev + + subroutine set_n_target(solver, n_target) bind(C, name="set_n_target") + import :: c_ptr, c_int + type(c_ptr), value :: solver + integer(c_int), value :: n_target + end subroutine set_n_target + + subroutine set_start_array(solver, n_start, start) & + bind(C, name="set_start_array") + import :: c_ptr, c_int, c_double_complex + type(c_ptr), value :: solver + integer(c_int), value :: n_start + complex(c_double_complex), intent(in) :: start(*) + end subroutine set_start_array + + subroutine set_n_split_x(solver, n_split_x) bind(C, name="set_n_split_x") + import :: c_ptr, c_int + type(c_ptr), value :: solver + integer(c_int), value :: n_split_x + end subroutine set_n_split_x + + subroutine set_n_split_y(solver, n_split_y) bind(C, name="set_n_split_y") + import :: c_ptr, c_int + type(c_ptr), value :: solver + integer(c_int), value :: n_split_y + end subroutine set_n_split_y + + subroutine set_max_iter_num(solver, max_iter_num) & + bind(C, name="set_max_iter_num") + import :: c_ptr, c_int + type(c_ptr), value :: solver + integer(c_int), value :: max_iter_num + end subroutine set_max_iter_num + + subroutine set_eps_for_arg(solver, abs_eps_z, rel_eps_z) & + bind(C, name="set_eps_for_arg") + import :: c_ptr, c_double + type(c_ptr), value :: solver + real(c_double), value :: abs_eps_z, rel_eps_z + end subroutine set_eps_for_arg + + subroutine set_eps_for_func(solver, abs_eps_f, rel_eps_f) & + bind(C, name="set_eps_for_func") + import :: c_ptr, c_double + type(c_ptr), value :: solver + real(c_double), value :: abs_eps_f, rel_eps_f + end subroutine set_eps_for_func + + subroutine set_use_winding(solver, use_winding) bind(C, name="set_use_winding") + import :: c_ptr, c_int + type(c_ptr), value :: solver + integer(c_int), value :: use_winding + end subroutine set_use_winding + + subroutine set_debug_level(solver, debug_level) bind(C, name="set_debug_level") + import :: c_ptr, c_int + type(c_ptr), value :: solver + integer(c_int), value :: debug_level + end subroutine set_debug_level + + subroutine set_print_level(solver, print_level) bind(C, name="set_print_level") + import :: c_ptr, c_int + type(c_ptr), value :: solver + integer(c_int), value :: print_level + end subroutine set_print_level + end interface + +contains + + !> --- multi-start hybrid Newton search (oracle find_det_zeros) --- + + function find_det_zeros(ind, m, n, cd) bind(C, name="find_det_zeros") result(stat) + integer(c_int), value :: ind, m, n + integer(c_intptr_t), value :: cd + integer(c_int) :: stat + + type(det_params_t), target :: p + character(len=1024) :: full_name + integer :: u, k + real(c_double) :: x_init(2), x_root(2), det_out(2) + real(dp) :: radius + complex(dp) :: center, quad1, quad2 + + stat = 0 + + p%ind = ind + p%m = m + p%n = n + p%delta = es_delta + p%cd = cd + + call build_output_name(cd, full_name) + + open (newunit=u, file=trim(full_name), status='replace', action='write') + write (u, '(a)') '%Re(f)'//tab()//tab()//tab()//'Im(f)'//tab()//tab()//tab()// & + 'Re(det)'//tab()//tab()//tab()//'Im(det)' + close (u) + + do k = es_kmin, es_kmax + open (newunit=u, file=trim(full_name), position='append', action='write') + + x_init(1) = real(es_fstart(k), c_double) + x_init(2) = aimag(es_fstart(k)) + + stat = fortnum_multiroot_hybrid(c_funloc(eval_det_residual), 2_c_int, & + x_init, real(es_eps_abs, c_double), real(es_eps_res, c_double), & + 1000000_c_int, x_root, c_loc(p)) + + call eval_determinant_core(p, real(x_root(1), dp), real(x_root(2), dp), & + det_out(1), det_out(2)) + + write (u, '(es27.20e2, 2x, es27.20e2, a, es27.20e2, 2x, es27.20e2)') & + x_root(1), x_root(2), tab(), det_out(1), det_out(2) + write (u, '(a, i0)') '%status = ', stat + + if (es_test_roots == 1) then + radius = 1.0e1_dp + + center = cmplx(x_root(1), x_root(2), dp) + quad1 = calc_circle_integral(p, center, radius) + + center = center + 5.0_dp*radius*(1.0_dp + im) + quad2 = calc_circle_integral(p, center, radius) + + write (output_unit, & + '(a, es27.20e2, 1x, es27.20e2, a, es27.20e2, 1x, es27.20e2)') & + 'quad1 = ', real(quad1, dp), aimag(quad1), tab()//'quad2 = ', & + real(quad2, dp), aimag(quad2) + + write (u, & + '(a, es27.20e2, 1x, es27.20e2, a, es27.20e2, 1x, '// & + 'es27.20e2, a, es27.20e2)') & + '%quad1 = ', real(quad1, dp), aimag(quad1), tab()//'quad2 = ', & + real(quad2, dp), aimag(quad2), tab()//'err = ', abs(quad1/quad2) + end if + + close (u) + end do + end function find_det_zeros + + !> Closed circle quadrature of inv_det around center (oracle + !> calc_circle_integral). The oracle's function-pointer argument had a + !> single possible value (inv_det), so it is called directly here. + function calc_circle_integral(p, center, radius) result(res) + type(det_params_t), intent(in) :: p + complex(dp), intent(in) :: center + real(dp), intent(in) :: radius + complex(dp) :: res, expon + real(dp) :: dphi + integer, parameter :: n = 100 + integer :: k + + dphi = 2.0_dp*pi/n + res = (0.0_dp, 0.0_dp) + do k = 0, n - 1 + expon = exp(k*dphi*im) + res = res + inv_det(p, center + radius*expon)*expon + end do + res = dphi*im*radius*res + end function calc_circle_integral + + !> Reciprocal of the determinant at z (oracle inv_det, E/det with E = 1). + function inv_det(p, z) result(res) + type(det_params_t), intent(in) :: p + complex(dp), intent(in) :: z + complex(dp) :: res, det + real(dp) :: det_re, det_im + + call eval_determinant_core(p, real(z, dp), aimag(z), det_re, det_im) + det = cmplx(det_re, det_im, dp) + res = (1.0_dp, 0.0_dp)/det + end function inv_det + + !> Imaginary part of the determinant on the imaginary frequency axis + !> (oracle calc_det). Kept as an exported entry point, matching the + !> oracle header, though no caller exists in the codebase. + subroutine calc_det(p, freq, absdet) + type(det_params_t), intent(in) :: p + real(dp), intent(in) :: freq + real(dp), intent(out) :: absdet + real(dp) :: det_re, det_im + + call eval_determinant_core(p, 0.0_dp, freq, det_re, det_im) + absdet = det_im + end subroutine calc_det + + !> --- brute-force 2D frequency scan (oracle loop_over_frequences) --- + + function loop_over_frequences(ind, m, n, cd) bind(C, name="loop_over_frequences") & + result(stat) + integer(c_int), value :: ind, m, n + integer(c_intptr_t), value :: cd + integer(c_int) :: stat + + character(len=1024) :: full_name + integer :: u, i, k + real(dp) :: fre, fim, det_re, det_im + + call build_output_name(cd, full_name) + + open (newunit=u, file=trim(full_name), status='replace', action='write') + write (u, '(a)') '%iter'//tab()//'Re(f)'//tab()//tab()//tab()//'Im(f)'// & + tab()//tab()//tab()//'Re(det)'//tab()//tab()//tab()//'Im(det)' + + do i = 0, es_rdim - 1 + fre = es_rfmin + real(i, dp)*(es_rfmax - es_rfmin) & + /real(max(es_rdim - 1, 1), dp) + + do k = 0, es_idim - 1 + fim = es_ifmin + real(k, dp)*(es_ifmax - es_ifmin) & + /real(max(es_idim - 1, 1), dp) + + call compute_det(ind, m, n, cd, fre, fim, det_re, det_im) + + write (u, '(i6, a, es27.20e2, 2x, es27.20e2, a, '// & + 'es27.20e2, 2x, es27.20e2)') & + i*es_idim + k, tab(), fre, fim, tab(), det_re, det_im + end do + end do + + close (u) + stat = 0 + end function loop_over_frequences + + !> --- reliable zeros search via the ZerSol C wrapper (oracle find_eigmodes) --- + + function find_eigmodes(ind, m, n, cd) bind(C, name="find_eigmodes") result(stat) + integer(c_int), value :: ind, m, n + integer(c_intptr_t), value :: cd + integer(c_int) :: stat + + integer(c_int), parameter :: max_n_zeros = 128 + type(det_params_t), target :: p + type(c_ptr) :: solver + complex(c_double_complex) :: z(0:max_n_zeros - 1), v(0:max_n_zeros - 1) + complex(c_double_complex), allocatable :: es_fstart_loc(:) + integer(c_int) :: n_zeros + character(len=1024) :: full_name + integer :: u, i, k + + p%ind = ind + p%m = m + p%n = n + p%delta = es_delta + p%cd = cd + + solver = create_solver(c_funloc(determinant_cb), c_null_funptr, c_loc(p), & + 'determinant'//c_null_char, real(es_rfmin, c_double), & + real(es_rfmax, c_double), real(es_ifmin, c_double), & + real(es_ifmax, c_double)) + + call set_nd_method(solver, 1_c_int) + if (es_delta > 0.0_dp) call set_nd_step(solver, real(es_delta, c_double)) + + call set_min_rec_lev(solver, 8_c_int) + + allocate (es_fstart_loc(0:es_nguess - 1)) + do k = 0, es_nguess - 1 + es_fstart_loc(k) = cmplx(real(es_fstart(k), c_double), & + aimag(es_fstart(k)), c_double_complex) + end do + + call set_n_target(solver, int(es_n_zeros, c_int)) + call set_start_array(solver, int(es_nguess, c_int), es_fstart_loc) + call set_n_split_x(solver, 4_c_int) + call set_n_split_y(solver, 4_c_int) + call set_max_iter_num(solver, 24_c_int) + call set_eps_for_arg(solver, real(es_eps_abs, c_double), & + real(es_eps_rel, c_double)) + call set_eps_for_func(solver, 0.0_c_double, real(es_eps_res, c_double)) + call set_use_winding(solver, int(es_use_winding, c_int)) + call set_debug_level(solver, 1_c_int) + call set_print_level(solver, 1_c_int) + + n_zeros = 0 + stat = find_zeros(solver, max_n_zeros, z, v, n_zeros) + + if (stat /= 0) call print_dump(solver, c_null_char) + + call print_status(solver, c_null_char) + call print_dump(solver, 'search.dump'//c_null_char) + + call free_solver(solver) + + deallocate (es_fstart_loc) + + call build_output_name(cd, full_name) + + open (newunit=u, file=trim(full_name), status='replace', action='write') + write (u, '(a)') '%#'//tab()//'Re(f)'//tab()//tab()//tab()//tab()//'Im(f)'// & + tab()//tab()//tab()//tab()//'Re(det)'//tab()//tab()//tab()//tab()//'Im(det)' + + do i = 0, n_zeros - 1 + write (u, '(i5, a, es27.20e2, 2x, es27.20e2, a, '// & + 'es27.20e2, 2x, es27.20e2)') & + i, tab(), real(z(i), dp), aimag(z(i)), tab(), & + real(v(i), dp), aimag(v(i)) + end do + + close (u) + stat = 0 + end function find_eigmodes + + !> --- shared determinant evaluation --- + + !> fortnum_vector_fn residual shim: x = (Re f, Im f), f = (Re det, Im det). + subroutine eval_det_residual(n, x, f, params) bind(C) + integer(c_int), value :: n + real(c_double), intent(in) :: x(*) + real(c_double), intent(out) :: f(*) + type(c_ptr), value :: params + type(det_params_t), pointer :: p + + call c_f_pointer(params, p) + call eval_determinant_core(p, real(x(1), dp), real(x(2), dp), f(1), f(2)) + end subroutine eval_det_residual + + !> ZerSol complex_function shim: z (complex frequency) -> determinant value. + function determinant_cb(z, params) result(res) bind(C) + complex(c_double_complex), value :: z + type(c_ptr), value :: params + complex(c_double_complex) :: res + type(det_params_t), pointer :: p + real(dp) :: det_re, det_im + + call c_f_pointer(params, p) + call eval_determinant_core(p, real(z, dp), aimag(z), det_re, det_im) + res = cmplx(det_re, det_im, c_double_complex) + end function determinant_cb + + !> Determinant at (fre, fim) plus the oracle's det.dat debug append, the + !> body shared by eval_det and the templated determinant. + subroutine eval_determinant_core(p, fre, fim, det_re, det_im) + type(det_params_t), intent(in) :: p + real(dp), intent(in) :: fre, fim + real(dp), intent(out) :: det_re, det_im + integer :: u + + call compute_det(p%ind, p%m, p%n, p%cd, fre, fim, det_re, det_im) + + open (newunit=u, file='det.dat', position='append', action='write') + write (u, '(es27.20e2, 1x, es27.20e2, a, es27.20e2, 1x, es27.20e2)') & + fre, fim, tab(), det_re, det_im + close (u) + end subroutine eval_determinant_core + + !> Build mode_data at olab = 2 pi (fre + i fim), evaluate the dispersion + !> determinant, then tear the mode_data back down - the create / calc / + !> read / destroy sequence common to all three search paths. + subroutine compute_det(ind, m, n, cd, fre, fim, det_re, det_im) + integer(c_int), intent(in) :: ind, m, n + integer(c_intptr_t), intent(in) :: cd + real(dp), intent(in) :: fre, fim + real(dp), intent(out) :: det_re, det_im + real(c_double) :: olab_re, olab_im + integer(c_intptr_t) :: sd, bp, mdh, wdh + type(c_ptr) :: wd_cptr + character(kind=c_char) :: path_c(1024) + + olab_re = 2.0_dp*pi*fre + olab_im = 2.0_dp*pi*fim + + sd = core_data_get_sd_(cd) + bp = core_data_get_bp_(cd) + + call settings_get_path2project_(sd, path_c) + + mdh = mode_data_create_(m, n, olab_re, olab_im, sd, bp, path_c) + call core_data_set_mda_element_(cd, ind, mdh) + + call mode_data_calc_all_mode_data_(core_data_get_mda_element_(cd, ind), 0_c_int) + + wdh = mode_data_get_wd_(core_data_get_mda_element_(cd, ind)) + wd_cptr = transfer(wdh, wd_cptr) + det_re = wave_data_get_det_re(wd_cptr) + det_im = wave_data_get_det_im(wd_cptr) + + call mode_data_destroy_(core_data_get_mda_element_(cd, ind)) + call core_data_set_mda_element_(cd, ind, 0_c_intptr_t) + call clear_all_data_in_mode_data_module() + end subroutine compute_det + + !> --- helpers --- + + !> full output path: settings path2project followed by the eigmode file + !> name (oracle sprintf("%s%s", path2project, es_fname)). + subroutine build_output_name(cd, full_name) + integer(c_intptr_t), intent(in) :: cd + character(len=*), intent(out) :: full_name + character(kind=c_char) :: path_c(1024) + character(len=1024) :: path + integer :: i + + call settings_get_path2project_(core_data_get_sd_(cd), path_c) + + path = '' + do i = 1, 1024 + if (path_c(i) == c_null_char) exit + path(i:i) = path_c(i) + end do + + full_name = trim(path)//trim(es_fname) + end subroutine build_output_name + + pure function tab() result(c) + character(len=1) :: c + c = achar(9) + end function tab + +end module kilca_eigmode_solve_m diff --git a/KiLCA/eigmode/find_eigmodes.cpp b/KiLCA/eigmode/find_eigmodes.cpp deleted file mode 100644 index 14fd6050..00000000 --- a/KiLCA/eigmode/find_eigmodes.cpp +++ /dev/null @@ -1,144 +0,0 @@ -/*! \file find_eigmodes.cpp - \brief The implementation of the reliable zeros search algorithm. -*/ - -#include -#include -#include - -#include "zerosolver.hpp" - -#include "eigmode_sett.h" -#include "calc_eigmode.h" -#include "inout.h" -#include "mode.h" - -/**********************************************************************************/ - -template std::complex determinant (const std::complex & freq, void * params) -{ -int ind = ((det_params *) params)->ind; -int m = ((det_params *) params)->m; -int n = ((det_params *) params)->n; - -core_data *cd = ((det_params *) params)->cd; - -cd->mda[ind] = new mode_data (m, n, 2.0*pi*freq, (const settings *)cd->sd, (const background *)cd->bp); - -cd->mda[ind]->calc_all_mode_data (); - -complex det = (cd->mda[ind])->wd->det; - -//if (DEBUG_FLAG) -//{ - FILE *out; - if (!(out = fopen ("det.dat", "a"))) - { - fprintf (stderr, "\nFailed to open file %s\a\n", "det.dat"); - } - - fprintf (out, "\n%.20le %.20le\t%.20le %.20le", real(freq), imag(freq), real(det), imag(det)); - - fclose (out); -//} - -//clean up: -delete cd->mda[ind]; -cd->mda[ind] = NULL; -clear_all_data_in_mode_data_module_ (); //clean up fortran module data - -return det; -} - -/**********************************************************************************/ - -int find_eigmodes (int ind, int m, int n, core_data *cd) -{ -const eigmode_sett *es = cd->sd->es; - -using namespace std; -using namespace type; -using namespace alg; - -typedef double P; // define double precision for the zeros search algorithm (recommended) - -det_params p = {ind, m, n, es->delta, cd}; - -type::Function

F(determinant, 0, &p, "determinant"); // define the function object with numerical evaluation of the derivative -F.set_nd_method(1); // set the fourth order accurate finite difference approximation -if (es->delta > 0.0) F.set_nd_step(es->delta); // set the stepsize for evaluation of numerical derivative - -type::Box

B(es->rfmin, es->rfmax, es->ifmin, es->ifmax); - -alg::zersol::Settings

S; // define the default solver setings - -//the winding number settings: -S.set_min_rec_lev(8); // set the minimum recursion level for the function argument evaluation -//S.set_max_rec_lev(16); // set the maximum recursion level for the function argument evaluation -//S.set_interp_err(1.0e-2); // set the tolerance of interpolation used in the function argument evaluation -//S.set_jump_err(1.0e-2); // set the tolerance of test for the function argument discontinuities - -//Newton iterations settings: -S.set_n_target(es->n_zeros); // set the target number of the function zeros -S.set_start_array(es->Nguess, es->fstart); // set user supplied starting array -S.set_n_split_x(4); // set the number of automatic starting points along Re{z} -S.set_n_split_y(4); // set the number of automatic starting points along Im{z} -S.set_max_iter_num(24); // set the maximum number of Newton iterations for each starting point -S.set_eps_for_arg(es->eps_abs, es->eps_rel); // set absolute and relative tolerances for convergence condition on z -S.set_eps_for_func(0.0, es->eps_res); // set absolute and relative tolerances for convergence condition on f(z) - -//the region partition settings: -S.set_use_winding(es->use_winding); // define whether the solver will use the winding number evaluation or just simple Newton's iterations -//S.set_max_part_level(64); // set the maximum level of the rectangle partition -S.set_debug_level(1); // set the debug level (amount of internal checks) -S.set_print_level(1); // set the print level (amount of the details printed) - -alg::zersol::ZeroSolver

solver(F, B, S); // define the solver with the specified F, B, S - -if (DEBUG_FLAG) std::cout << S; - -int max_n_zeros = 128, n_zeros = 0; // specify maximum and current number of wanted zeros - -std::complex

Z[max_n_zeros], V[max_n_zeros]; // allocate arrays for zeros and values of the function - -int status = solver.FindZeros(max_n_zeros, Z, V, n_zeros); // the solver sets Z, V, n_zeros and returns 0 if successful - -if (status) // do something: throw an exception, try another settings, etc... -{ - std::clog << solver; // dump the solver data to log stream. The log stream can be redirected to a file if desired. -} - -solver.print_status(); // the solver prints information about the search status - -//if (DEBUG_FLAG) // dump the solver data to file -//{ - std::ofstream file("search.dump", std::ofstream::out); - file << solver; - file.close(); -//} - -//output file: -char *full_name = new char[1024]; -sprintf (full_name, "%s%s", cd->sd->path2project, es->fname); - -FILE *out; -if (!(out = fopen (full_name, "w"))) -{ - fprintf (stderr, "\nFailed to open file %s\a\n", full_name); -} - -fprintf (out, "%%#\tRe(f)\t\t\t\tIm(f)\t\t\t\tRe(det)\t\t\t\tIm(det)"); - -for (int i = 0; i < n_zeros; ++i) -{ - fprintf (out, "\n%5u\t%.20le %.20le\t%.20le %.20le", i, real(Z[i]), imag(Z[i]), real(V[i]), imag(V[i])); -} - -fclose (out); - -delete [] full_name; - -return 0; -} - -/**********************************************************************************/ diff --git a/KiLCA/flre/conductivity/calc_cond.cpp b/KiLCA/flre/conductivity/calc_cond.cpp deleted file mode 100644 index 78dcb7a0..00000000 --- a/KiLCA/flre/conductivity/calc_cond.cpp +++ /dev/null @@ -1,682 +0,0 @@ -/*! \file calc_cond.cpp - \brief The implementation of functions declared in calc_cond.h. -*/ - -#include -#include -#include -#include -#include - -#include "calc_cond.h" -#include "cond_profs.h" -#include "shared.h" - -/*******************************************************************/ - -void sample_cond_func (double *r, double *f, void *p) -{ -cond_profiles *cp = (cond_profiles *)(p); - -cp->xt[cp->ind] = *r; - -char *flag_back = cp->flag_back; - -eval_and_set_background_parameters_spec_independent_ (r, flag_back, 1); -eval_and_set_wave_parameters_ (r, flag_back, 1); - -eval_a_matrix_ (); -calc_dem_djmi_arrays_ (r); - -int type; - -for (int spec=0; spec<2; spec++) -{ - eval_and_set_background_parameters_spec_dependent_ (r, &spec, flag_back, 1); - eval_and_set_f0_parameters_nu_and_derivs_ (r, &spec, flag_back, 1); - eval_electric_drift_velocities_ (); - eval_fgi_arrays_ (); - calc_w2_array_ (&spec); - calc_d_array_ (); - - //print_conduct_params_ (); - //print_conduct_arrays_ (); - - type = 0; - calc_k_matrices_ (cp->yt + cp->iKa(spec, type, 0, 0, 0, 0, 0, cp->ind)); - - type = 1; - calc_k1_matrices_ (cp->yt + cp->iKa(spec, type, 0, 0, 0, 0, 0, cp->ind)); -} - -//target function: imag(k0033): weigthed sum of imag parts. -*f = 2.0e3*(cp->yt[cp->iKa(0, 0, 0, 0, 2, 2, 1, cp->ind)]); //ions -*f += 1.0e0*(cp->yt[cp->iKa(1, 0, 0, 0, 2, 2, 1, cp->ind)]); //electrons: - -(cp->ind)++; -} - -/*******************************************************************/ - -void sample_cond_func_polynom (double *r, double *f, void *p) -{ -cond_profiles *cp = (cond_profiles *)(p); - -char *flag_back = cp->flag_back; - -eval_and_set_background_parameters_spec_independent_ (r, flag_back, 1); -eval_and_set_wave_parameters_ (r, flag_back, 1); - -eval_a_matrix_ (); -calc_dem_djmi_arrays_ (r); - -int type; - -for (int spec=0; spec<2; spec++) -{ - eval_and_set_background_parameters_spec_dependent_ (r, &spec, flag_back, 1); - eval_and_set_f0_parameters_nu_and_derivs_ (r, &spec, flag_back, 1); - eval_electric_drift_velocities_ (); - eval_fgi_arrays_ (); - calc_w2_array_ (&spec); - calc_d_array_ (); - - type = 0; - calc_k_matrices_ (f + cp->iKa(spec, type, 0, 0, 0, 0, 0, 0)); - - type = 1; - calc_k1_matrices_ (f + cp->iKa(spec, type, 0, 0, 0, 0, 0, 0)); -} -} - -/*******************************************************************/ - -void calc_splines_for_K (cond_profiles *cp) -{ -/*K profiles memory aligment: -{spec=0:1, {[{p=0:flreo, {q=0:flreo, {i=0:2, {j=0:2], {(re, im), {i=0:dimx-1}}}}}}}} -*/ -/*sorting grid points*/ -size_t *perm = new size_t[cp->dimx]; - -sort_index_doubles (perm, cp->xt, cp->dimx); - -//rearanging K array for splining: -for (int node=0; nodedimx; node++) -{ - cp->x[node] = cp->xt[perm[node]]; - for (int spec=0; spec<2; spec++) - { - for (int type=0; typedimt; type++) - { - for (int p=0; p<=cp->flreo; p++) - { - for (int q=0; q<=cp->flreo; q++) - { - for (int i=0; i<3; i++) - { - for (int j=0; j<3; j++) - { - for (int part=0; part<2; part++) - { - cp->K [cp->iKs(spec, type, p, q, i, j, part, node)] = - cp->yt[cp->iKa(spec, type, p, q, i, j, part, perm[node])]; - } - } - } - } - } - } - } -} - -delete [] perm; - -spline_alloc_ (cp->NK, 1, cp->dimx, cp->x, cp->CK, &(cp->sidK)); - -int ierr; -spline_calc_ (cp->sidK, cp->K, 0, cp->dimK-1, NULL, &ierr); - -if (DEBUG_FLAG) fprintf (stdout, "\nK profiles are splined...\n"); -} - -/*******************************************************************/ - -void calc_splines_for_K_polynom (cond_profiles *cp) -{ -/*K profiles memory aligment: -{spec=0:1, {[{p=0:flreo, {q=0:flreo, {i=0:2, {j=0:2], {(re, im), {i=0:dimx-1}}}}}}}} -*/ - -//rearanging K array for splining: -for (int node=0; nodedimx; node++) -{ - cp->x[node] = cp->xt[node]; - for (int spec=0; spec<2; spec++) - { - for (int type=0; typedimt; type++) - { - for (int p=0; p<=cp->flreo; p++) - { - for (int q=0; q<=cp->flreo; q++) - { - for (int i=0; i<3; i++) - { - for (int j=0; j<3; j++) - { - for (int part=0; part<2; part++) - { - cp->K [cp->iKs(spec, type, p, q, i, j, part, node)] = - cp->yt[cp->iKa(spec, type, p, q, i, j, part, node)]; - } - } - } - } - } - } - } -} - -spline_alloc_ (cp->NK, 1, cp->dimx, cp->x, cp->CK, &(cp->sidK)); - -int ierr; -spline_calc_ (cp->sidK, cp->K, 0, cp->dimK-1, NULL, &ierr); - -if (DEBUG_FLAG) fprintf (stdout, "\nK profiles are splined...\n"); -} - -/*******************************************************************/ - -void calc_splines_for_C (cond_profiles *cp) -{ -for (int spec=0; spec<2; spec++) //over species -{ - for (int type=0; typedimt; type++) //over types - { - for (int node=0; nodedimx; node++) //over r grid - { - calc_C_matrices (cp, spec, type, cp->x[node], cp->RC); - - for (int s=0; s<=2*(cp->flreo); s++) - { - for (int i=0; i<3; i++) - { - for (int j=0; j<3; j++) - { - for (int part=0; part<2; part++) - { - - cp->C[cp->iCs(spec, type, s, i, j, part, node)] = - cp->RC[cp->iCa(s, i, j, part)]; - } - } - } - } - } - } -} - -spline_alloc_ (cp->NC, 1, cp->dimx, cp->x, cp->CC, &(cp->sidC)); - -int ierr; -spline_calc_ (cp->sidC, cp->C, 0, cp->dimC-1, NULL, &ierr); - -if (DEBUG_FLAG) fprintf (stdout, "\nC profiles are splined...\n"); -} - -/*******************************************************************/ - -void calc_C_matrices (const cond_profiles *cp, int spec, int type, double r, double *C) -{ -int flreo = cp->flreo; -int dimc = 9*(2*flreo+1); - -//K-matrices and derivs up to flreo: huge_factor is included! -eval_K_matrices (cp, spec, type, 0, flreo, r, cp->RK); - -complex *Cm = new complex[dimc]; - -for (int k=0; kbico[m+p-n+(p-n)*(flreo+1)]); - for (int i=0; i<3; i++) - { - for (int j=0; j<3; j++) - { - //K[p,q,i,j]: (re, im) - int ind = 2*(j+3*(i+3*(n+(flreo+1)*(m+p-n)))); - - Cm[j+3*(i+3*p)] += coeff*((cp->RK[ind+0+m*dimk])+ - (cp->RK[ind+1+m*dimk])*I); - } - } - } - } -} - -double scale_fac; - -if (cp->flag_back[0] != 'f') scale_fac = cp->sd->bs->huge_factor; -else scale_fac = 1.0e0; - -complex cft = 2.0*pi*I*(cp->sd->bs->charge[spec])*(cp->sd->bs->charge[spec])/ - (cp->wd->omov)/(r*scale_fac); - -for (int k=0; kgal_corr==1 && cp->flag_back[0]=='f' && type==0 && flreo==1) -{ - calc_and_add_galilelian_correction_ (&r, &spec, cp->flag_back, C, 1); -} - -//if use conduct factor: insert here! - -delete [] Cm; -} - -/*******************************************************************/ - -void save_K_matrices (const cond_profiles *cp, int spec, int type) -{ -//spec=-1 means total = i+e -char reim[2][3] = {{"re"}, {"im"}}; -char *full_name = new char[1024]; - -FILE *outfile; - -int flreo = cp->flreo; - -double k_m; - -for (int p=0; p<=flreo; p++) -{ - for (int q=0; q<=flreo; q++) - { - for (int part=0; part<2; part++) - { - sprintf (full_name, "%s%s%d%d%s%s%s", cp->path2linear, "debug-data/kt_", p, q, "_", reim[part], ".dat"); - - if (!(outfile = fopen (full_name, "w"))) - { - fprintf (stderr, "\nFailed to open file %s\a\n", full_name); - } - - for (int k=0; kdimx; k++) - { - //fprintf (outfile, "%.16le", cp->x[k]); - for (int i=0; i<3; i++) - { - for (int j=0; j<3; j++) - { - if (spec == -1) - { - k_m = cp->K[cp->iKs(0, type, p, q, i, j, part, k)] + - cp->K[cp->iKs(1, type, p, q, i, j, part, k)]; - } - else - { - k_m = cp->K[cp->iKs(spec, type, p, q, i, j, part, k)]; - } - fprintf (outfile, "%.16le\t", k_m); - } - } - fprintf (outfile, "%.16le", cp->x[k]); - fprintf (outfile, "\n"); - } - fclose (outfile); - } - } -} -delete [] full_name; -} - -/*******************************************************************/ - -void save_C_matrices (const cond_profiles *cp, int spec, int type) -{ -//spec=-1 means total = i+e -char reim[2][3] = {{"re"}, {"im"}}; -char *full_name = new char[1024]; - -FILE *outfile; - -//int flreo = cp->sd->cs->flre_order; -//int dimc = 9*(2*flreo+1); -//int D = 2*(cp->dimx)*dimc*2; //type=0:1 - -double c_m; - -for (int p=0; p<=2*(cp->flreo); p++) -{ - for (int part=0; part<2; part++) - { - sprintf (full_name, "%s%s%d%s%s%s", cp->path2linear, "debug-data/ct_", p, "_", reim[part], ".dat"); - - if (!(outfile = fopen (full_name, "w"))) - { - fprintf (stderr, "\nFailed to open file %s\a\n", full_name); - } - - for (int k=0; kdimx; k++) - { - //fprintf (outfile, "%.16le", cp->x[k]); - for (int i=0; i<3; i++) - { - for (int j=0; j<3; j++) - { - //int ind_c = j + 3*i + 9*p + 9*(2*flreo+1)*type; - //int ind_a = k + part*(cp->dimx) + 2*(cp->dimx)*ind_c; - - if (spec == -1) - { - //c_m = cp->C[ind_a+0*D] + cp->C[ind_a+1*D]; - c_m = cp->C[cp->iCs(0, type, p, i, j, part, k)] + - cp->C[cp->iCs(1, type, p, i, j, part, k)]; - } - else - { - //c_m = cp->C[ind_a + spec*D]; - c_m = cp->C[cp->iCs(spec, type, p, i, j, part, k)]; - } - //fprintf (outfile, "\t%.16le", k_tot); - fprintf (outfile, "%.16le\t", c_m); - } - } - fprintf (outfile, "%.16le", cp->x[k]); - fprintf (outfile, "\n"); - } - fclose (outfile); - } -} -delete [] full_name; -} - -/*******************************************************************/ - -void save_C_matrices_fine (const cond_profiles *cp, int spec, int type, int dimf) -{ -//spec=-1 means total = i+e -char *full_name = new char[1024]; - -FILE *outfile; - -int dimC = 2*9*(2*(cp->flreo)+1); - -double *Ci = new double[dimC]; -double *Ce = new double[dimC]; -double *C = new double[dimC]; - -sprintf (full_name, "%s%s", cp->path2linear, "debug-data/ct.dat"); - -if (!(outfile = fopen (full_name, "w"))) -{ - fprintf (stderr, "\nFailed to open file %s\a\n", full_name); -} - -for (int k=0; kdimx-1; k++) -{ - for (int s=0; sx[k] + s*(cp->x[k+1] - cp->x[k])/dimf; - - if (spec == -1) - { - eval_C_matrices (cp, 0, type, 0, 0, r, Ci); - eval_C_matrices (cp, 1, type, 0, 0, r, Ce); - - for (int l=0; lflreo+1)*(cp->flreo+1)*3*3*2; - -double *Ki = new double[dimK]; -double *Ke = new double[dimK]; -double *K = new double[dimK]; - -sprintf (full_name, "%s%s", cp->path2linear, "debug-data/kt.dat"); - -if (!(outfile = fopen (full_name, "w"))) -{ - fprintf (stderr, "\nFailed to open file %s\a\n", full_name); -} - -for (int k=0; kdimx-1; k++) -{ - for (int s=0; sx[k] + s*(cp->x[k+1] - cp->x[k])/dimf; - - if (spec == -1) - { - eval_K_matrices (cp, 0, type, 0, 0, r, Ki); - eval_K_matrices (cp, 1, type, 0, 0, r, Ke); - - for (int l=0; ldimx]; - -sort_index_doubles (perm, cp->xt, cp->dimx); - -//rearanging K array for splining: -for (int node=0; nodedimx; node++) -{ - cp->x[node] = cp->xt[perm[node]]; - for (int spec=0; spec<2; spec++) - { - for (int type=0; typedimt; type++) - { - for (int p=0; p<=cp->flreo; p++) - { - for (int q=0; q<=cp->flreo; q++) - { - for (int i=0; i<3; i++) - { - for (int j=0; j<3; j++) - { - for (int part=0; part<2; part++) - { - cp->K [cp->iKs(spec, type, p, q, i, j, part, node)] = - cp->yt[cp->iKa(spec, type, p, q, i, j, part, perm[node])]; - } - } - } - } - } - } - } -} - -delete [] perm; -} - -/*******************************************************************/ - -void set_arrays_for_K_polynom (cond_profiles *cp) -{ -/*K profiles memory aligment: -{spec=0:1, {[{p=0:flreo, {q=0:flreo, {i=0:2, {j=0:2], {(re, im), {i=0:dimx-1}}}}}}}} -*/ - -//rearanging K array for splining: -for (int node=0; nodedimx; node++) -{ - cp->x[node] = cp->xt[node]; - for (int spec=0; spec<2; spec++) - { - for (int type=0; typedimt; type++) - { - for (int p=0; p<=cp->flreo; p++) - { - for (int q=0; q<=cp->flreo; q++) - { - for (int i=0; i<3; i++) - { - for (int j=0; j<3; j++) - { - for (int part=0; part<2; part++) - { - cp->K [cp->iKs(spec, type, p, q, i, j, part, node)] = - cp->yt[cp->iKa(spec, type, p, q, i, j, part, node)]; - } - } - } - } - } - } - } -} -} - -/*******************************************************************/ - -void smooth_arrays_for_K (cond_profiles *cp) -{ -/*K profiles memory aligment: -{spec=0:1, {[{p=0:flreo, {q=0:flreo, {i=0:2, {j=0:2], {(re, im), {i=0:dimx-1}}}}}}}} -*/ -/*sorting grid points*/ -size_t *perm = new size_t[cp->dimx]; - -sort_index_doubles (perm, cp->xt, cp->dimx); - -for (int node=0; nodedimx; node++) -{ - cp->x[node] = cp->xt[perm[node]]; -} - -delete [] perm; - -//smooth the grid: -int ngauss = 50; smooth_array_gauss_(&(cp->dimx), &ngauss, cp->x); - -//resampling K array: -char * flag_back = cp->flag_back; - -for (int node=0; nodedimx; node++) -{ - double * r = &(cp->x[node]); - - eval_and_set_background_parameters_spec_independent_ (r, flag_back, 1); - eval_and_set_wave_parameters_ (r, flag_back, 1); - - eval_a_matrix_ (); - calc_dem_djmi_arrays_ (r); - - for (int spec=0; spec<2; spec++) - { - eval_and_set_background_parameters_spec_dependent_ (r, &spec, flag_back, 1); - eval_and_set_f0_parameters_nu_and_derivs_ (r, &spec, flag_back, 1); - eval_electric_drift_velocities_ (); - eval_fgi_arrays_ (); - calc_w2_array_ (&spec); - calc_d_array_ (); - - //print_conduct_params_ (); - //print_conduct_arrays_ (); - - int type = 0; - calc_k_matrices_ (cp->yt + cp->iKa(spec, type, 0, 0, 0, 0, 0, 0)); - } - - for (int spec=0; spec<2; spec++) - { - for (int type=0; type<1; type++) - { - for (int p=0; p<=cp->flreo; p++) - { - for (int q=0; q<=cp->flreo; q++) - { - for (int i=0; i<3; i++) - { - for (int j=0; j<3; j++) - { - for (int part=0; part<2; part++) - { - cp->K [cp->iKs(spec, type, p, q, i, j, part, node)] = - cp->yt[cp->iKa(spec, type, p, q, i, j, part, 0)]; - } - } - } - } - } - } - } -} -} - -/*******************************************************************/ diff --git a/KiLCA/flre/conductivity/calc_cond.h b/KiLCA/flre/conductivity/calc_cond.h deleted file mode 100644 index 41be93eb..00000000 --- a/KiLCA/flre/conductivity/calc_cond.h +++ /dev/null @@ -1,60 +0,0 @@ -/*! \file calc_cond.h - \brief The declarations of functions used to calculate conductivity matrices and their splines. -*/ - -#ifndef CALC_COND_INCLUDE - -#define CALC_COND_INCLUDE - -#include "settings.h" -#include "adaptive_grid.h" -#include "constants.h" -#include "settings.h" -#include "background.h" -#include "cond_profs.h" -#include "spline.h" -#include "conduct_parameters.h" -#include "eval_cond.h" - -void sample_cond_func (double *r, double *f, void *p); -void calc_splines_for_K (cond_profiles *cp); -void set_arrays_for_K (cond_profiles *cp); -void smooth_arrays_for_K (cond_profiles *cp); - -void sample_cond_func_polynom (double *r, double *f, void *p); -void calc_splines_for_K_polynom (cond_profiles *cp); -void set_arrays_for_K_polynom (cond_profiles *cp); - -void save_K_matrices (const cond_profiles *cp, int spec, int type); -void save_K_matrices_fine (const cond_profiles *cp, int spec, int type, int dimf); - -void calc_splines_for_C (cond_profiles *cp); -void calc_C_matrices (const cond_profiles *cp, int spec, int type, double r, double *C); -void save_C_matrices (const cond_profiles *cp, int spec, int type); -void save_C_matrices_fine (const cond_profiles *cp, int spec, int type, int dimf); - -extern "C" -{ -void calc_and_add_galilelian_correction_ (double *r, int *spec, char *flag_back, double *ct, int len); - -void eval_electric_drift_velocities_ (void); -void eval_fgi_arrays_ (void); -void eval_a_matrix_ (void); -void calc_dem_djmi_arrays_ (double *); - -void calc_w1_array_ (void); -void calc_w2_array_ (int *); -void calc_d_array_ (void); -void calc_k_matrices_ (double *); -void calc_k1_matrices_ (double *); -void calc_dummy_matrices_ (double *); - -void transform_c_matrices_to_rsp_ (double *, double *); - -void print_conduct_params_ (void); -void print_conduct_arrays_ (void); - -void smooth_array_gauss_ (int *, int *, double *); -} - -#endif diff --git a/KiLCA/flre/conductivity/cond_profs.cpp b/KiLCA/flre/conductivity/cond_profs.cpp deleted file mode 100644 index 38b5914b..00000000 --- a/KiLCA/flre/conductivity/cond_profs.cpp +++ /dev/null @@ -1,264 +0,0 @@ -/*! \file cond_profs.cpp - \brief The implementation of functions declared in cond_profs.h (version with simple interpolation used to generate adaptive radial grid). -*/ - -#include -#include -#include -#include -#include - -#include "cond_profs.h" -#include "calc_cond.h" -#include "core.h" -#include "calc_back.h" -#include "shared.h" -#include "flre_zone.h" - -/*******************************************************************/ - -void alloc_conductivity_profiles_ (cond_profiles **cpptr) -{ -cond_profiles *cp = new cond_profiles; -*cpptr = cp; -} - -/*******************************************************************/ - -void cond_profiles::calc_and_spline_main_conductivity_profiles (const flre_zone *zone, int flag) -{ -sd = zone->get_settings (); -bp = zone->get_background (); -wd = zone->get_wave_data (); - -r1 = zone->r1; -r2 = zone->r2; - -D = zone->D; -eps_out = zone->eps_out; -eps_res = zone->eps_res; - -flag_back = new char[8]; -strcpy (flag_back, sd->bs->flag_back); - -path2linear = new char[1024]; - -eval_path_to_linear_data (zone->get_path_to_project(), wd->m, wd->n, wd->olab, path2linear); - -flreo = zone->flre_order; - -gal_corr = zone->gal_corr; - -//binomial coefficients: -bico = new double[(flreo+1)*(flreo+1)]; - -binomial_coefficients (flreo, bico); - -/*conductivity K profiles: spec=0:1, [type=0:dimt-1, p=0:flreo, q=0:flreo, i=0:2, j=0:2], (re, im)*/ -NK = zone->N + flreo + 1; //splines degree for K matrices in rsp - odd! -dimt = 2; //2 types of K matrices -dimK = 2*(dimt)*(flreo+1)*(flreo+1)*3*3*2; - -//arrays for temp adaptive grid: -int max_dim = zone->max_dim_c; - -xt = new double[max_dim]; -yt = new double[dimK*max_dim]; - -//arrays for adaptive grid: -double *xa = new double[max_dim]; -double *ya = new double[max_dim]; - -//boundaries: -xa[0] = max (r1-1.0, bp->x[0]); -xa[2] = min (r2+1.0, bp->x[bp->dimx-1]); - -if (xa[0] > r1 || xa[2] < r2) -{ - fprintf (stdout, "\nwarning: xa[0] or xa[2] is inside the zone.\n"); - fflush (stdout); - exit(1); -} - -if (wd->r_res != 0.0e0) -{ - xa[1] = 1.01*(wd->r_res); -} -else -{ - xa[1] = 0.5*(xa[0]+xa[2]); -} - -int dimxa = 3; - -ind = 0; //x grid index - -for (int i=0; iflag_debug > 1) -{ - save_K_matrices (this, -1, 0); //spec, type - - //save_K_matrices_fine (this, -1, 0, 10); //spec, type -} - -if (flag) return; - -NC = zone->N; //splines degree for C matrices - -/*conductivity C profiles: spec=0:1, [type=0:dimt-1,s=0..2flreo, i=0:2, j=0:2], (re, im)*/ -dimC = 2*dimt*(2*flreo+1)*3*3*2; -C = new double[dimx*dimC]; -CC = new double[(NC+1)*dimx*dimC]; -RC = new double[(NC+1)*dimC]; - -calc_splines_for_C (this); - -if (zone->flag_debug > 1) -{ - save_C_matrices (this, -1, 0); //spec, type - - //save_C_matrices_fine (this, -1, 0, 10); //spec, type -} -} - -/*******************************************************************/ - -void delete_conductivity_profiles_f_ (cond_profiles **cp_ptr) -{ -delete *cp_ptr; -} - -/*******************************************************************/ - -void calc_and_spline_conductivity_for_point_ (settings **sd_ptr, background **bp_ptr, - wave_data **wd_ptr, char *flag_back, - double *r, cond_profiles **cp_ptr) -{ -//it is assumed that flre_sett and all other fortran modules are set properly! - -alloc_conductivity_profiles_ (cp_ptr); - -cond_profiles *cp = (cond_profiles *)(*cp_ptr); - -cp->sd = (const settings *) (*sd_ptr); -cp->bp = (const background *)(*bp_ptr); -cp->wd = (const wave_data *) (*wd_ptr); - -cp->flag_back = new char[8]; -cp->flag_back[0] = flag_back[0]; - -cp->path2linear = NULL; //not needed in this case - -get_flre_order_ (&(cp->flreo)); - -get_gal_corr_ (&(cp->gal_corr)); - -//binomial coefficients: -cp->bico = new double[(cp->flreo+1)*(cp->flreo+1)]; - -binomial_coefficients (cp->flreo, cp->bico); - -cp->NK = cp->sd->bs->N - (cp->flreo + 1); //flreo is assumed to be odd - -cp->dimt = 2; //2 types of K matrices -cp->dimK = 2*(cp->dimt)*(cp->flreo+1)*(cp->flreo+1)*3*3*2; - -int max_dim = max(3*(cp->NK + 1), 9); //minimum possible dimension for splines - -cp->xt = new double[max_dim]; -cp->yt = new double[max_dim*(cp->dimK)]; - -//arrays for adaptive grid: -double *xa = new double[max_dim]; -double *ya = new double[max_dim]; - -//interval for splining around point *r: -double delta = 0.01*(cp->bp->x[cp->bp->dimx-1] - cp->bp->x[0]); //interval width -double rmin = fmax(cp->bp->x[0], *r-delta); //left boundary -double rmax = fmin(cp->bp->x[cp->bp->dimx-1], *r+delta); //right boundary - -//boundaries: -xa[0] = rmin; -xa[2] = rmax; -xa[1] = 0.5*(xa[0]+xa[2]); - -int dimxa = 3; - -cp->ind = 0; //x grid index - -for (int i=0; iind != dimxa) -{ - fprintf (stdout, "\nerror: calc_and_spline_conductivity_profiles_for_point: ind=%d\tdimxa=%d\n", cp->ind, dimxa); - fflush (stdout); - exit (1); -} - -delete [] xa; -delete [] ya; - -cp->dimx = dimxa; -cp->x = new double[cp->dimx]; - -cp->K = new double[(cp->dimx)*(cp->dimK)]; -cp->CK = new double[(cp->dimx)*(cp->dimK)*(cp->NK+1)]; -cp->RK = new double[(cp->NK+1)*(cp->dimK)]; - -calc_splines_for_K (cp); - -delete [] cp->xt; -delete [] cp->yt; - -/*conductivity C profiles: spec=0:1, [type=0:dimt-1,s=0..2flreo, i=0:2, j=0:2], (re, im)*/ -cp->NC = cp->NK - (cp->flreo + 1); //flreo is assumed to be odd -cp->dimC = 2*(cp->dimt)*(2*(cp->flreo)+1)*3*3*2; -cp->C = new double[(cp->dimx)*(cp->dimC)]; -cp->CC = new double[(cp->NC+1)*(cp->dimx)*(cp->dimC)]; -cp->RC = new double[(cp->NC+1)*(cp->dimC)]; - -calc_splines_for_C (cp); -} - -/*******************************************************************/ diff --git a/KiLCA/flre/conductivity/cond_profs.h b/KiLCA/flre/conductivity/cond_profs.h deleted file mode 100644 index 06d53eaf..00000000 --- a/KiLCA/flre/conductivity/cond_profs.h +++ /dev/null @@ -1,151 +0,0 @@ -/*! \file cond_profs.h - \brief The declaration of cond_profiles class. -*/ - -#ifndef COND_PROFS_INCLUDE - -#define COND_PROFS_INCLUDE - -#include -#include - -#include "constants.h" -#include "settings.h" -#include "background.h" -#include "wave_data.h" -#include "spline.h" - -/*! \class cond_profiles - \brief Class containes conductivity profiles. -*/ -class cond_profiles -{ -public: - ///external data which are used for calculations: - const settings *sd; //!dimx)*(part + 2*(j + 3*(i + 3*(q + (this->flreo+1)*(p + - (this->flreo+1)*(type + (this->dimt)*(spec))))))); - } - - int iKa (int spec, int type, int p, int q, int i, int j, int part, int node) const - { - ///index of the element in initial K array of matrices: - return part + 2*(j + 3*(i + 3*(q + (this->flreo+1)*(p + (this->flreo+1)* - (type + (this->dimt)*(spec + 2*node)))))); - } - - int iCs (int spec, int type, int s, int i, int j, int part, int node) const - { - ///index of the element in C array for splines: - return node + (this->dimx)*(part + 2*(j + 3*(i + 3*(s + (2*(this->flreo)+1)* - (type + (this->dimt)*(spec)))))); - } - - int iCa (int s, int i, int j, int part) const - { - ///index of the element in C matrix: - return part + 2*(j + 3*(i + 3*s)); - } -}; - -extern "C" -{ -void alloc_conductivity_profiles_ (cond_profiles **cpptr); - -void calc_and_spline_conductivity_for_point_ (settings **sd_ptr, background **bp_ptr, - wave_data **wd_ptr, char *flag_back, double *r, - cond_profiles **cp_ptr); - -void delete_conductivity_profiles_f_ (cond_profiles **cp_ptr); -} - -#endif diff --git a/KiLCA/flre/conductivity/cond_profs_m.f90 b/KiLCA/flre/conductivity/cond_profs_m.f90 new file mode 100644 index 00000000..fff97fe8 --- /dev/null +++ b/KiLCA/flre/conductivity/cond_profs_m.f90 @@ -0,0 +1,982 @@ +!> Conductivity (K and C matrix) profiles for a flre_zone, formerly the C++ +!> cond_profiles class. Per-instance handle (same pattern as +!> kilca_spline_m/kilca_maxwell_eqs_data_m/kilca_sysmat_profiles_m), since each +!> flre_zone owns its own instance. +!> +!> Only the live (polynomial-grid) path is translated: the "exact" per-point +!> fallback (calc_and_spline_conductivity_for_point_/alloc_conductivity_ +!> profiles_/the second branch of ctensor/kmatrices in conductivity.f90) is +!> provably unreachable -- background's flag_back is read once at startup +!> (background_m.f90) and never reassigned, so the `backflag == flag_back` +!> guard in ctensor/kmatrices is always true. Likewise the non-_polynom +!> siblings (sample_cond_func, calc_splines_for_K, set_arrays_for_K, +!> smooth_arrays_for_K) and the *_fine debug dumpers are dead (only reachable +!> via the inactive cond_profs.cpp or commented-out call sites). +!> +!> sd/bp (settings*/background*) are write-only in the C++ constructor (read +!> nowhere else in cond_profiles), so they are not translated at all; wd +!> (wave_data*) is only read for path2linear/omov/r_res at construction time, +!> so the caller (flre_zone.cpp, still C++) passes those directly instead of +!> an opaque wave_data handle. +module kilca_cond_profiles_m + use, intrinsic :: iso_c_binding, only: c_int, c_intptr_t, c_double, c_char, & + c_ptr, c_funptr, c_funloc, c_loc, c_f_pointer, c_null_ptr, c_null_char + implicit none + private + + public :: cond_profiles_create, cond_profiles_destroy + public :: get_cond_nk, get_cond_dimk, get_cond_nc, get_cond_dimc + public :: get_cond_dimx, get_cond_x_ptr, get_cond_k_ptr, get_cond_iks + public :: get_cond_flag_back, get_cond_path2linear + public :: eval_all_k_matrices, eval_all_c_matrices + public :: eval_c_matrices_f, eval_k_matrices_f + public :: calc_and_spline_conductivity_for_point, delete_conductivity_profiles_f + + real(c_double), parameter :: pi = 3.141592653589793238462643383279502884197d0 + + type :: cond_profiles_t + character(len=1) :: flag_back + character(len=1024) :: path2linear + integer(c_int) :: flreo, gal_corr, dimt + integer(c_int) :: NK, NC + complex(c_double) :: omov + integer(c_int) :: dimx + real(c_double), allocatable :: x(:) + integer(c_int) :: dimK + real(c_double), allocatable :: K(:) + real(c_double), allocatable :: CK(:) + real(c_double), allocatable :: RK(:) + integer(c_intptr_t) :: sidK = 0 + integer(c_int) :: dimC + real(c_double), allocatable :: C(:) + real(c_double), allocatable :: CC(:) + real(c_double), allocatable :: RC(:) + integer(c_intptr_t) :: sidC = 0 + real(c_double), allocatable :: bico(:) + real(c_double), allocatable :: xt(:) + real(c_double), allocatable :: yt(:) + end type cond_profiles_t + + interface + function adaptive_grid_polynom_res(f, p, a, b, dimy, deg, xdim, eps, & + r_res, D, eps_res, dim_err, ind_err, x1, y1) result(stat) & + bind(C, name="adaptive_grid_polynom_res") + import :: c_funptr, c_ptr, c_int, c_double + type(c_funptr), value :: f + type(c_ptr), value :: p + real(c_double), value :: a, b, r_res, D, eps_res + real(c_double), intent(inout) :: eps + integer(c_int), value :: dimy, deg, dim_err + integer(c_int), intent(inout) :: xdim + integer(c_int), intent(in) :: ind_err(*) + real(c_double), intent(inout) :: x1(*), y1(*) + integer(c_int) :: stat + end function adaptive_grid_polynom_res + + subroutine spline_alloc_c(N, styp, dimx, x, Carr, sid) bind(C, name="spline_alloc_") + import :: c_int, c_double, c_intptr_t + integer(c_int), value :: N, styp, dimx + real(c_double), intent(in) :: x(*) + real(c_double), intent(inout) :: Carr(*) + integer(c_intptr_t), intent(out) :: sid + end subroutine spline_alloc_c + + subroutine spline_calc_c(sid, y, Imin, Imax, W, ierr) bind(C, name="spline_calc_") + import :: c_intptr_t, c_double, c_int, c_ptr + integer(c_intptr_t), value :: sid + real(c_double), intent(in) :: y(*) + integer(c_int), value :: Imin, Imax + type(c_ptr), value :: W + integer(c_int), intent(out) :: ierr + end subroutine spline_calc_c + + subroutine spline_eval_d_c(sid, dimz, z, Dmin, Dmax, Imin, Imax, R) & + bind(C, name="spline_eval_d_") + import :: c_intptr_t, c_double, c_int + integer(c_intptr_t), value :: sid + integer(c_int), value :: dimz, Dmin, Dmax, Imin, Imax + real(c_double), intent(in) :: z(*) + real(c_double), intent(out) :: R(*) + end subroutine spline_eval_d_c + + subroutine spline_free_c(sid) bind(C, name="spline_free_") + import :: c_intptr_t + integer(c_intptr_t), value :: sid + end subroutine spline_free_c + + subroutine binomial_coefficients_c(N, BC) bind(C, name="binomial_coefficients_") + import :: c_int, c_double + integer(c_int), value :: N + real(c_double), intent(out) :: BC(*) + end subroutine binomial_coefficients_c + + subroutine eval_and_set_background_parameters_spec_independent_c(r, flagback, fb_len) & + bind(C, name="eval_and_set_background_parameters_spec_independent_") + import :: c_double, c_char, c_int + real(c_double), intent(in) :: r + character(kind=c_char), intent(in) :: flagback(*) + integer(c_int), value :: fb_len + end subroutine eval_and_set_background_parameters_spec_independent_c + + subroutine eval_and_set_wave_parameters_c(r, flagback, fb_len) & + bind(C, name="eval_and_set_wave_parameters_") + import :: c_double, c_char, c_int + real(c_double), intent(in) :: r + character(kind=c_char), intent(in) :: flagback(*) + integer(c_int), value :: fb_len + end subroutine eval_and_set_wave_parameters_c + + subroutine eval_a_matrix_c() bind(C, name="eval_a_matrix_") + end subroutine eval_a_matrix_c + + subroutine calc_dem_djmi_arrays_c(r) bind(C, name="calc_dem_djmi_arrays_") + import :: c_double + real(c_double), intent(in) :: r + end subroutine calc_dem_djmi_arrays_c + + subroutine eval_and_set_background_parameters_spec_dependent_c(r, spec, flagback, fb_len) & + bind(C, name="eval_and_set_background_parameters_spec_dependent_") + import :: c_double, c_int, c_char + real(c_double), intent(in) :: r + integer(c_int), intent(in) :: spec + character(kind=c_char), intent(in) :: flagback(*) + integer(c_int), value :: fb_len + end subroutine eval_and_set_background_parameters_spec_dependent_c + + subroutine eval_and_set_f0_parameters_nu_and_derivs_c(r, spec, flagback, fb_len) & + bind(C, name="eval_and_set_f0_parameters_nu_and_derivs_") + import :: c_double, c_int, c_char + real(c_double), intent(in) :: r + integer(c_int), intent(in) :: spec + character(kind=c_char), intent(in) :: flagback(*) + integer(c_int), value :: fb_len + end subroutine eval_and_set_f0_parameters_nu_and_derivs_c + + subroutine eval_electric_drift_velocities_c() bind(C, name="eval_electric_drift_velocities_") + end subroutine eval_electric_drift_velocities_c + + subroutine eval_fgi_arrays_c() bind(C, name="eval_fgi_arrays_") + end subroutine eval_fgi_arrays_c + + subroutine calc_w2_array_c(spec) bind(C, name="calc_w2_array_") + import :: c_int + integer(c_int), intent(in) :: spec + end subroutine calc_w2_array_c + + subroutine calc_d_array_c() bind(C, name="calc_d_array_") + end subroutine calc_d_array_c + + subroutine calc_k_matrices_c(K) bind(C, name="calc_k_matrices_") + import :: c_double + real(c_double), intent(out) :: K(*) + end subroutine calc_k_matrices_c + + subroutine calc_k1_matrices_c(K) bind(C, name="calc_k1_matrices_") + import :: c_double + real(c_double), intent(out) :: K(*) + end subroutine calc_k1_matrices_c + + subroutine calc_and_add_galilelian_correction_c(r, spec, flagback, ct, fb_len) & + bind(C, name="calc_and_add_galilelian_correction_") + import :: c_double, c_int, c_char + real(c_double), intent(in) :: r + integer(c_int), intent(in) :: spec + character(kind=c_char), intent(in) :: flagback(*) + real(c_double), intent(inout) :: ct(*) + integer(c_int), value :: fb_len + end subroutine calc_and_add_galilelian_correction_c + + real(c_double) function get_background_huge_factor_c() bind(C, name="get_background_huge_factor_") + import :: c_double + end function get_background_huge_factor_c + + real(c_double) function get_background_charge_c(i) bind(C, name="get_background_charge_") + import :: c_int, c_double + integer(c_int), value :: i + end function get_background_charge_c + + function get_background_flag_back_c() result(ch) bind(C, name="get_background_flag_back_") + import :: c_char + character(kind=c_char) :: ch + end function get_background_flag_back_c + + integer(c_int) function get_background_n_c() bind(C, name="get_background_N_") + import :: c_int + end function get_background_n_c + + subroutine get_flre_order_c(flre_order) bind(C, name="get_flre_order_") + import :: c_int + integer(c_int), intent(out) :: flre_order + end subroutine get_flre_order_c + + subroutine get_gal_corr_c(gal_corr) bind(C, name="get_gal_corr_") + import :: c_int + integer(c_int), intent(out) :: gal_corr + end subroutine get_gal_corr_c + + real(c_double) function get_background_obj_x0_c() bind(C, name="get_background_x0_") + import :: c_double + end function get_background_obj_x0_c + + real(c_double) function get_background_obj_xlast_c() bind(C, name="get_background_xlast_") + import :: c_double + end function get_background_obj_xlast_c + + real(c_double) function get_wave_data_obj_omov_re_c(wd) bind(C, name="get_wave_data_obj_omov_re_") + import :: c_double, c_ptr + type(c_ptr), value :: wd + end function get_wave_data_obj_omov_re_c + + real(c_double) function get_wave_data_obj_omov_im_c(wd) bind(C, name="get_wave_data_obj_omov_im_") + import :: c_double, c_ptr + type(c_ptr), value :: wd + end function get_wave_data_obj_omov_im_c + + function adaptive_grid_polynom_err(f, p, a, b, dimy, deg, xdim, eps, & + dim_err, ind_err, x1, y1) result(stat) & + bind(C, name="adaptive_grid_polynom_err") + import :: c_funptr, c_ptr, c_int, c_double + type(c_funptr), value :: f + type(c_ptr), value :: p + real(c_double), value :: a, b + integer(c_int), value :: dimy, deg, dim_err + integer(c_int), intent(inout) :: xdim + real(c_double), intent(inout) :: eps + integer(c_int), intent(in) :: ind_err(*) + real(c_double), intent(inout) :: x1(*), y1(*) + integer(c_int) :: stat + end function adaptive_grid_polynom_err + end interface + +contains + + integer(c_int) function iKs(cp, spec, ttype, p, q, i, j, part, node) result(idx) + type(cond_profiles_t), intent(in) :: cp + integer(c_int), intent(in) :: spec, ttype, p, q, i, j, part, node + idx = node + cp%dimx*(part + 2*(j + 3*(i + 3*(q + (cp%flreo + 1)*(p + & + (cp%flreo + 1)*(ttype + cp%dimt*spec)))))) + end function iKs + + integer(c_int) function iKa(cp, spec, ttype, p, q, i, j, part, node) result(idx) + type(cond_profiles_t), intent(in) :: cp + integer(c_int), intent(in) :: spec, ttype, p, q, i, j, part, node + idx = part + 2*(j + 3*(i + 3*(q + (cp%flreo + 1)*(p + (cp%flreo + 1)*( & + ttype + cp%dimt*(spec + 2*node)))))) + end function iKa + + integer(c_int) function iCs(cp, spec, ttype, s, i, j, part, node) result(idx) + type(cond_profiles_t), intent(in) :: cp + integer(c_int), intent(in) :: spec, ttype, s, i, j, part, node + idx = node + cp%dimx*(part + 2*(j + 3*(i + 3*(s + (2*cp%flreo + 1)*( & + ttype + cp%dimt*spec))))) + end function iCs + + integer(c_int) function iCa(s, i, j, part) result(idx) + integer(c_int), intent(in) :: s, i, j, part + idx = part + 2*(j + 3*(i + 3*s)) + end function iCa + + !> path2linear_p: caller-computed (via eval_path_to_linear_data, still + !> C++) null-terminated string. a/b: caller-computed adaptive-grid + !> bounds (max(r1-1,bp->x[0])/min(r2+1,bp->x[dimx-1])) since bp (the C++ + !> background physics instance) is not Fortran-resident. r_res/omov_re/ + !> omov_im: from the zone's still-C++ wave_data instance. + function cond_profiles_create(path2linear_p, flreo, gal_corr, N, max_dim_c, & + r1, r2, D, eps_out, eps_res, a, b, r_res, omov_re, omov_im, flag_debug, flag) & + result(handle) bind(C, name="cond_profiles_create_") + type(c_ptr), value :: path2linear_p + integer(c_int), value :: flreo, gal_corr, N, max_dim_c, flag_debug, flag + real(c_double), value :: r1, r2, D, eps_out, eps_res, a, b, r_res, omov_re, omov_im + integer(c_intptr_t) :: handle + + type(cond_profiles_t), pointer :: cp + integer(c_int) :: l, dim_err + integer(c_int), allocatable :: ind_err(:) + integer(c_int) :: spec, ttype, p, q, i, j, part + real(c_double) :: epso, epsi + integer(c_int) :: stat_unused + + allocate (cp) + cp%flag_back = get_background_flag_back_c() + call read_c_string(path2linear_p, cp%path2linear) + + cp%flreo = flreo + cp%gal_corr = gal_corr + cp%omov = cmplx(omov_re, omov_im, c_double) + cp%NK = N + flreo + 1 + + allocate (cp%bico(0:(flreo + 1)*(flreo + 1) - 1)) + call binomial_coefficients_c(flreo, cp%bico) + + cp%dimt = 2 + cp%dimK = 2*cp%dimt*(flreo + 1)*(flreo + 1)*3*3*2 + + cp%dimx = max_dim_c + allocate (cp%xt(0:cp%dimx - 1)) + allocate (cp%yt(0:cp%dimK*cp%dimx - 1)) + + if (a > r1 .or. b < r2) then + write (*, '(a)') 'warning: a or b is inside the zone.' + stop 1 + end if + + dim_err = 2*3*3*2 + allocate (ind_err(0:dim_err - 1)) + l = 0 + do spec = 0, 1 + do ttype = 0, 0 + do p = 0, 0 + do q = 0, 0 + do i = 0, 2 + do j = 0, 2 + do part = 0, 1 + ind_err(l) = iKa(cp, spec, ttype, p, q, i, j, part, 0) + l = l + 1 + end do + end do + end do + end do + end do + end do + end do + + epso = eps_out + epsi = eps_res + stat_unused = adaptive_grid_polynom_res(c_funloc(sample_cond_func_polynom), c_loc(cp), & + a, b, cp%dimK, cp%NK, cp%dimx, epso, & + r_res, D, epsi, dim_err, ind_err, cp%xt, cp%yt) + deallocate (ind_err) + + allocate (cp%x(0:cp%dimx - 1)) + allocate (cp%K(0:cp%dimx*cp%dimK - 1)) + allocate (cp%CK(0:cp%dimx*cp%dimK*(cp%NK + 1) - 1)) + allocate (cp%RK(0:(cp%NK + 1)*cp%dimK - 1)) + + if (flag == 0) then + call calc_splines_for_K_polynom(cp) + else + call set_arrays_for_K_polynom(cp) + end if + + deallocate (cp%xt) + deallocate (cp%yt) + + if (flag_debug > 1) call save_K_matrices(cp, -1, 0) + + if (flag == 0) then + cp%NC = N + cp%dimC = 2*cp%dimt*(2*flreo + 1)*3*3*2 + allocate (cp%C(0:cp%dimx*cp%dimC - 1)) + allocate (cp%CC(0:(cp%NC + 1)*cp%dimx*cp%dimC - 1)) + allocate (cp%RC(0:(cp%NC + 1)*cp%dimC - 1)) + + call calc_splines_for_C(cp) + + if (flag_debug > 1) call save_C_matrices(cp, -1, 0) + end if + + handle = transfer(c_loc(cp), handle) + end function cond_profiles_create + + subroutine cond_profiles_destroy(handle) bind(C, name="cond_profiles_destroy_") + integer(c_intptr_t), value :: handle + type(cond_profiles_t), pointer :: cp + + if (handle == 0_c_intptr_t) return + call handle_to_cp(handle, cp) + if (cp%sidK /= 0) call spline_free_c(cp%sidK) + if (cp%sidC /= 0) call spline_free_c(cp%sidC) + deallocate (cp) + end subroutine cond_profiles_destroy + + !> bind(C) replacement for calc_and_spline_conductivity_for_point_, + !> reachable only via the provably-dead branch in ctensor/kmatrices + !> (conductivity.f90), but translated in full since the symbol is + !> statically referenced by that still-live Fortran code. sd_ptr/bp_ptr/ + !> wd_ptr/cp_ptr are passed BY REFERENCE (non-VALUE), matching the + !> original `settings **sd_ptr`/`cond_profiles **cp_ptr` C ABI that + !> conductivity.f90's implicit-interface call expects (same convention as + !> eval_c_matrices_f/eval_k_matrices_f above). bp_ptr is accepted for ABI + !> compatibility but unused: background is now a Fortran singleton (see + !> kilca_background_data_m), so its x0/xlast come from that module's own + !> getters regardless of the handle value. wd is still a per-zone C++ + !> instance, so its needed field is read through a small additive C++ + !> accessor (get_wave_data_obj_omov_*_). + subroutine calc_and_spline_conductivity_for_point(sd_ptr, bp_ptr, wd_ptr, & + flag_back_p, r, cp_ptr) bind(C, name="calc_and_spline_conductivity_for_point_") + integer(c_intptr_t), intent(in) :: sd_ptr, bp_ptr, wd_ptr + character(kind=c_char), intent(in) :: flag_back_p(*) + real(c_double), intent(in) :: r + integer(c_intptr_t), intent(out) :: cp_ptr + + type(cond_profiles_t), pointer :: cp + type(c_ptr) :: wd_cptr + integer(c_int) :: l, dim_err + integer(c_int), allocatable :: ind_err(:) + integer(c_int) :: spec, ttype, p, q, i, j, part + real(c_double) :: delta, a, b, eps + real(c_double) :: bp_x0, bp_xlast, omov_re, omov_im + integer(c_int) :: stat_unused + + allocate (cp) + + wd_cptr = transfer(wd_ptr, wd_cptr) + + cp%flag_back = flag_back_p(1) + cp%path2linear = '' + + call get_flre_order_c(cp%flreo) + call get_gal_corr_c(cp%gal_corr) + + allocate (cp%bico(0:(cp%flreo + 1)*(cp%flreo + 1) - 1)) + call binomial_coefficients_c(cp%flreo, cp%bico) + + cp%NK = get_background_n_c() - (cp%flreo + 1) + + cp%dimt = 2 + cp%dimK = 2*cp%dimt*(cp%flreo + 1)*(cp%flreo + 1)*3*3*2 + + cp%dimx = 3*(cp%NK + 1) + + allocate (cp%xt(0:cp%dimx - 1)) + allocate (cp%yt(0:cp%dimx*cp%dimK - 1)) + + bp_x0 = get_background_obj_x0_c() + bp_xlast = get_background_obj_xlast_c() + omov_re = get_wave_data_obj_omov_re_c(wd_cptr) + omov_im = get_wave_data_obj_omov_im_c(wd_cptr) + cp%omov = cmplx(omov_re, omov_im, c_double) + + delta = 0.01d0*(bp_xlast - bp_x0) + a = max(bp_x0, r - delta) + b = min(bp_xlast, r + delta) + + dim_err = 2*3*3*2 + allocate (ind_err(0:dim_err - 1)) + l = 0 + do spec = 0, 1 + do ttype = 0, 0 + do p = 0, 0 + do q = 0, 0 + do i = 0, 2 + do j = 0, 2 + do part = 0, 1 + ind_err(l) = iKa(cp, spec, ttype, p, q, i, j, part, 0) + l = l + 1 + end do + end do + end do + end do + end do + end do + end do + + eps = 0.0d0 + stat_unused = adaptive_grid_polynom_err(c_funloc(sample_cond_func_polynom), c_loc(cp), & + a, b, cp%dimK, cp%NK, cp%dimx, eps, & + dim_err, ind_err, cp%xt, cp%yt) + deallocate (ind_err) + + allocate (cp%x(0:cp%dimx - 1)) + allocate (cp%K(0:cp%dimx*cp%dimK - 1)) + allocate (cp%CK(0:cp%dimx*cp%dimK*(cp%NK + 1) - 1)) + allocate (cp%RK(0:(cp%NK + 1)*cp%dimK - 1)) + + call calc_splines_for_K_polynom(cp) + + deallocate (cp%xt) + deallocate (cp%yt) + + cp%NC = cp%NK - (cp%flreo + 1) + cp%dimC = 2*cp%dimt*(2*cp%flreo + 1)*3*3*2 + allocate (cp%C(0:cp%dimx*cp%dimC - 1)) + allocate (cp%CC(0:(cp%NC + 1)*cp%dimx*cp%dimC - 1)) + allocate (cp%RC(0:(cp%NC + 1)*cp%dimC - 1)) + + call calc_splines_for_C(cp) + + cp_ptr = transfer(c_loc(cp), cp_ptr) + end subroutine calc_and_spline_conductivity_for_point + + !> bind(C) replacement for delete_conductivity_profiles_f_ (same + !> reference-passing convention as above). + subroutine delete_conductivity_profiles_f(cp_ptr) bind(C, name="delete_conductivity_profiles_f_") + integer(c_intptr_t), intent(in) :: cp_ptr + type(cond_profiles_t), pointer :: cp + + call handle_to_cp(cp_ptr, cp) + if (cp%sidK /= 0) call spline_free_c(cp%sidK) + if (cp%sidC /= 0) call spline_free_c(cp%sidC) + deallocate (cp) + end subroutine delete_conductivity_profiles_f + + !> bind(C) callback matching void(double *r, double *f, void *p): mirrors + !> sample_cond_func_polynom exactly (target buffer is f, not *cp->yt). + subroutine sample_cond_func_polynom(r, f, p) bind(C) + real(c_double), intent(in) :: r + real(c_double), intent(out) :: f(*) + type(c_ptr), value :: p + type(cond_profiles_t), pointer :: cp + integer(c_int) :: spec, ttype + + call c_f_pointer(p, cp) + + call eval_and_set_background_parameters_spec_independent_c(r, cp%flag_back, 1_c_int) + call eval_and_set_wave_parameters_c(r, cp%flag_back, 1_c_int) + call eval_a_matrix_c() + call calc_dem_djmi_arrays_c(r) + + do spec = 0, 1 + call eval_and_set_background_parameters_spec_dependent_c(r, spec, cp%flag_back, 1_c_int) + call eval_and_set_f0_parameters_nu_and_derivs_c(r, spec, cp%flag_back, 1_c_int) + call eval_electric_drift_velocities_c() + call eval_fgi_arrays_c() + call calc_w2_array_c(spec) + call calc_d_array_c() + + ttype = 0 + call calc_k_matrices_c(f(iKa(cp, spec, ttype, 0, 0, 0, 0, 0, 0) + 1)) + + ttype = 1 + call calc_k1_matrices_c(f(iKa(cp, spec, ttype, 0, 0, 0, 0, 0, 0) + 1)) + end do + end subroutine sample_cond_func_polynom + + subroutine set_arrays_for_K_polynom(cp) + type(cond_profiles_t), intent(inout) :: cp + integer(c_int) :: node, spec, ttype, p, q, i, j, part + + do node = 0, cp%dimx - 1 + cp%x(node) = cp%xt(node) + do spec = 0, 1 + do ttype = 0, cp%dimt - 1 + do p = 0, cp%flreo + do q = 0, cp%flreo + do i = 0, 2 + do j = 0, 2 + do part = 0, 1 + cp%K(iKs(cp, spec, ttype, p, q, i, j, part, node)) = & + cp%yt(iKa(cp, spec, ttype, p, q, i, j, part, node)) + end do + end do + end do + end do + end do + end do + end do + end do + end subroutine set_arrays_for_K_polynom + + subroutine calc_splines_for_K_polynom(cp) + type(cond_profiles_t), intent(inout) :: cp + integer(c_int) :: ierr + + call set_arrays_for_K_polynom(cp) + + call spline_alloc_c(cp%NK, 1, cp%dimx, cp%x, cp%CK, cp%sidK) + call spline_calc_c(cp%sidK, cp%K, 0, cp%dimK - 1, c_null_ptr, ierr) + end subroutine calc_splines_for_K_polynom + + subroutine calc_splines_for_C(cp) + type(cond_profiles_t), intent(inout) :: cp + integer(c_int) :: spec, ttype, node, s, i, j, part, ierr + + do spec = 0, 1 + do ttype = 0, cp%dimt - 1 + do node = 0, cp%dimx - 1 + call calc_C_matrices(cp, spec, ttype, cp%x(node), cp%RC) + do s = 0, 2*cp%flreo + do i = 0, 2 + do j = 0, 2 + do part = 0, 1 + cp%C(iCs(cp, spec, ttype, s, i, j, part, node)) = & + cp%RC(iCa(s, i, j, part)) + end do + end do + end do + end do + end do + end do + end do + + call spline_alloc_c(cp%NC, 1, cp%dimx, cp%x, cp%CC, cp%sidC) + call spline_calc_c(cp%sidC, cp%C, 0, cp%dimC - 1, c_null_ptr, ierr) + end subroutine calc_splines_for_C + + !> Mirrors calc_C_matrices exactly: evaluates K-matrices and derivatives, + !> combines them via the binomial-coefficient sum into the C matrix, scales + !> by the conductivity prefactor, and applies the Galilean correction. + subroutine calc_C_matrices(cp, spec, ttype, r, Cout) + type(cond_profiles_t), intent(inout) :: cp + integer(c_int), intent(in) :: spec, ttype + real(c_double), intent(in) :: r + real(c_double), intent(out) :: Cout(*) + + integer(c_int) :: flreo, dimc, dimk, p, nmin, nmax, n, m, i, j, ind, k + real(c_double) :: coeff, scale_fac + complex(c_double) :: Cm(0:9*(2*cp%flreo + 1) - 1) + complex(c_double) :: cft + + flreo = cp%flreo + dimc = 9*(2*flreo + 1) + + call eval_K_matrices(cp, spec, ttype, 0, flreo, r, cp%RK) + + Cm = (0.0d0, 0.0d0) + + dimk = 2*9*(flreo + 1)*(flreo + 1) + + do p = 0, 2*flreo + nmin = max(0, p - flreo) + nmax = min(p, flreo) + do n = nmin, nmax + do m = 0, flreo - (p - n) + coeff = (-1.0d0)**(m + p - n)*cp%bico(m + p - n + (p - n)*(flreo + 1)) + do i = 0, 2 + do j = 0, 2 + ind = 2*(j + 3*(i + 3*(n + (flreo + 1)*(m + p - n)))) + Cm(j + 3*(i + 3*p)) = Cm(j + 3*(i + 3*p)) + & + coeff*cmplx(cp%RK(ind + m*dimk), cp%RK(ind + 1 + m*dimk), c_double) + end do + end do + end do + end do + end do + + if (cp%flag_back(1:1) /= 'f') then + scale_fac = get_background_huge_factor_c() + else + scale_fac = 1.0d0 + end if + + cft = 2.0d0*pi*(0.0d0, 1.0d0)*get_background_charge_c(spec)*get_background_charge_c(spec)/ & + cp%omov/(r*scale_fac) + + do k = 0, dimc - 1 + Cout(2*k + 1) = real(cft*Cm(k), c_double) + Cout(2*k + 2) = aimag(cft*Cm(k)) + end do + + if (cp%gal_corr == 1 .and. cp%flag_back(1:1) == 'f' .and. ttype == 0 .and. flreo == 1) then + call calc_and_add_galilelian_correction_c(r, spec, cp%flag_back, Cout, 1_c_int) + end if + end subroutine calc_C_matrices + + !> Matches the original eval_K_matrices: evaluates the spline (with + !> derivatives Dmin..Dmax) at r and undoes the huge_factor scaling applied + !> when flag_back != 'f'. + subroutine eval_K_matrices(cp, spec, ttype, Dmin, Dmax, r, Kout) + type(cond_profiles_t), intent(in) :: cp + integer(c_int), intent(in) :: spec, ttype, Dmin, Dmax + real(c_double), intent(in) :: r + real(c_double), intent(out) :: Kout(*) + integer(c_int) :: dimk, ind_ka, n, ind, jj + real(c_double) :: scale_fac, rloc(1) + + dimk = 2*9*(cp%flreo + 1)*(cp%flreo + 1) + ind_ka = iKa(cp, spec, ttype, 0, 0, 0, 0, 0, 0) + + rloc(1) = r + call spline_eval_d_c(cp%sidK, 1, rloc, Dmin, Dmax, ind_ka, ind_ka + dimk - 1, Kout) + + if (cp%flag_back(1:1) /= 'f') then + do n = Dmin, Dmax + scale_fac = get_background_huge_factor_c()**n + ind = dimk*(n - Dmin) + do jj = 0, dimk - 1 + Kout(jj + ind + 1) = Kout(jj + ind + 1)/scale_fac + end do + end do + end if + end subroutine eval_K_matrices + + !> Matches eval_C_matrices (per spec/type spline evaluation; dimc here + !> already counts (re,im) pairs, unlike calc_C_matrices' dimc). + subroutine eval_C_matrices(cp, spec, ttype, Dmin, Dmax, r, Cout) + type(cond_profiles_t), intent(in) :: cp + integer(c_int), intent(in) :: spec, ttype, Dmin, Dmax + real(c_double), intent(in) :: r + real(c_double), intent(out) :: Cout(*) + integer(c_int) :: dimc, ind_ca, n, ind, jj + real(c_double) :: scale_fac, rloc(1) + + dimc = 18*(2*cp%flreo + 1) + ind_ca = dimc*(ttype + cp%dimt*spec) + + rloc(1) = r + call spline_eval_d_c(cp%sidC, 1, rloc, Dmin, Dmax, ind_ca, ind_ca + dimc - 1, Cout) + + if (cp%flag_back(1:1) /= 'f') then + do n = Dmin, Dmax + scale_fac = get_background_huge_factor_c()**n + ind = dimc*(n - Dmin) + do jj = 0, dimc - 1 + Cout(jj + ind + 1) = Cout(jj + ind + 1)/scale_fac + end do + end do + end if + end subroutine eval_C_matrices + + !> bind(C) replacement for eval_c_matrices_f_, called from the still-live + !> Fortran ctensor (conductivity.f90), itself called every RHS evaluation + !> from diff_sys.f90. Handle and index args are passed BY REFERENCE, + !> matching the original `cond_profiles **cp_ptr`/`int *spec` C ABI that + !> conductivity.f90's implicit-interface call expects. + subroutine eval_c_matrices_f(cp_ptr, spec, ttype, Dmin, Dmax, r, ct) & + bind(C, name="eval_c_matrices_f_") + integer(c_intptr_t), intent(in) :: cp_ptr + integer(c_int), intent(in) :: spec, ttype, Dmin, Dmax + real(c_double), intent(in) :: r + real(c_double), intent(out) :: ct(*) + type(cond_profiles_t), pointer :: cp + + call handle_to_cp(cp_ptr, cp) + call eval_C_matrices(cp, spec, ttype, Dmin, Dmax, r, ct) + end subroutine eval_c_matrices_f + + !> bind(C) replacement for eval_k_matrices_f_ (same calling convention). + subroutine eval_k_matrices_f(cp_ptr, spec, ttype, Dmin, Dmax, r, km) & + bind(C, name="eval_k_matrices_f_") + integer(c_intptr_t), intent(in) :: cp_ptr + integer(c_int), intent(in) :: spec, ttype, Dmin, Dmax + real(c_double), intent(in) :: r + real(c_double), intent(out) :: km(*) + type(cond_profiles_t), pointer :: cp + + call handle_to_cp(cp_ptr, cp) + call eval_K_matrices(cp, spec, ttype, Dmin, Dmax, r, km) + end subroutine eval_k_matrices_f + + !> Matches eval_all_K_matrices: full dimK spline evaluation (no per-spec + !> index offset), same huge_factor unscaling. Handle by VALUE (called + !> from still-C++ flre_quants.cpp, normal C call convention). + subroutine eval_all_k_matrices(handle, Dmin, Dmax, r, Kout) bind(C, name="eval_all_k_matrices_") + integer(c_intptr_t), value :: handle + integer(c_int), value :: Dmin, Dmax + real(c_double), value :: r + real(c_double), intent(out) :: Kout(*) + type(cond_profiles_t), pointer :: cp + integer(c_int) :: dimk, n, ind, jj + real(c_double) :: scale_fac, rloc(1) + + call handle_to_cp(handle, cp) + dimk = cp%dimK + rloc(1) = r + call spline_eval_d_c(cp%sidK, 1, rloc, Dmin, Dmax, 0, dimk - 1, Kout) + + if (cp%flag_back(1:1) /= 'f') then + do n = Dmin, Dmax + scale_fac = get_background_huge_factor_c()**n + ind = dimk*(n - Dmin) + do jj = 0, dimk - 1 + Kout(jj + ind + 1) = Kout(jj + ind + 1)/scale_fac + end do + end do + end if + end subroutine eval_all_k_matrices + + !> Matches eval_all_C_matrices. + subroutine eval_all_c_matrices(handle, Dmin, Dmax, r, Cout) bind(C, name="eval_all_c_matrices_") + integer(c_intptr_t), value :: handle + integer(c_int), value :: Dmin, Dmax + real(c_double), value :: r + real(c_double), intent(out) :: Cout(*) + type(cond_profiles_t), pointer :: cp + integer(c_int) :: dimc, n, ind, jj + real(c_double) :: scale_fac, rloc(1) + + call handle_to_cp(handle, cp) + dimc = cp%dimC + rloc(1) = r + call spline_eval_d_c(cp%sidC, 1, rloc, Dmin, Dmax, 0, dimc - 1, Cout) + + if (cp%flag_back(1:1) /= 'f') then + do n = Dmin, Dmax + scale_fac = get_background_huge_factor_c()**n + ind = dimc*(n - Dmin) + do jj = 0, dimc - 1 + Cout(jj + ind + 1) = Cout(jj + ind + 1)/scale_fac + end do + end do + end if + end subroutine eval_all_c_matrices + + !> Debug dump (flag_debug > 1 only); numeric formatting is an + !> ES24.16/uppercase-E approximation of the original "%.16le", not + !> byte-identical -- acceptable since these files are not part of any + !> correctness-critical comparison. + subroutine save_K_matrices(cp, spec, ttype) + type(cond_profiles_t), intent(in) :: cp + integer(c_int), intent(in) :: spec, ttype + character(len=2) :: reim(0:1) + character(len=1024) :: fname + integer(c_int) :: p, q, part, k, i, j, u + real(c_double) :: k_m + + reim(0) = 're'; reim(1) = 'im' + + do p = 0, cp%flreo + do q = 0, cp%flreo + do part = 0, 1 + write (fname, '(a,a,i0,i0,a,a,a)') trim(cp%path2linear), & + 'debug-data/kt_', p, q, '_', trim(reim(part)), '.dat' + open (newunit=u, file=trim(fname), status='replace', action='write') + do k = 0, cp%dimx - 1 + do i = 0, 2 + do j = 0, 2 + if (spec == -1) then + k_m = cp%K(iKs(cp, 0, ttype, p, q, i, j, part, k)) + & + cp%K(iKs(cp, 1, ttype, p, q, i, j, part, k)) + else + k_m = cp%K(iKs(cp, spec, ttype, p, q, i, j, part, k)) + end if + write (u, '(es24.16,1x)', advance='no') k_m + end do + end do + write (u, '(es24.16)') cp%x(k) + end do + close (u) + end do + end do + end do + end subroutine save_K_matrices + + subroutine save_C_matrices(cp, spec, ttype) + type(cond_profiles_t), intent(in) :: cp + integer(c_int), intent(in) :: spec, ttype + character(len=2) :: reim(0:1) + character(len=1024) :: fname + integer(c_int) :: p, part, k, i, j, u + real(c_double) :: c_m + + reim(0) = 're'; reim(1) = 'im' + + do p = 0, 2*cp%flreo + do part = 0, 1 + write (fname, '(a,a,i0,a,a,a)') trim(cp%path2linear), & + 'debug-data/ct_', p, '_', trim(reim(part)), '.dat' + open (newunit=u, file=trim(fname), status='replace', action='write') + do k = 0, cp%dimx - 1 + do i = 0, 2 + do j = 0, 2 + if (spec == -1) then + c_m = cp%C(iCs(cp, 0, ttype, p, i, j, part, k)) + & + cp%C(iCs(cp, 1, ttype, p, i, j, part, k)) + else + c_m = cp%C(iCs(cp, spec, ttype, p, i, j, part, k)) + end if + write (u, '(es24.16,1x)', advance='no') c_m + end do + end do + write (u, '(es24.16)') cp%x(k) + end do + close (u) + end do + end do + end subroutine save_C_matrices + + integer(c_int) function get_cond_nk(handle) bind(C, name="get_cond_nk_") + integer(c_intptr_t), value :: handle + type(cond_profiles_t), pointer :: cp + call handle_to_cp(handle, cp) + get_cond_nk = cp%NK + end function get_cond_nk + + integer(c_int) function get_cond_dimk(handle) bind(C, name="get_cond_dimk_") + integer(c_intptr_t), value :: handle + type(cond_profiles_t), pointer :: cp + call handle_to_cp(handle, cp) + get_cond_dimk = cp%dimK + end function get_cond_dimk + + integer(c_int) function get_cond_nc(handle) bind(C, name="get_cond_nc_") + integer(c_intptr_t), value :: handle + type(cond_profiles_t), pointer :: cp + call handle_to_cp(handle, cp) + get_cond_nc = cp%NC + end function get_cond_nc + + integer(c_int) function get_cond_dimc(handle) bind(C, name="get_cond_dimc_") + integer(c_intptr_t), value :: handle + type(cond_profiles_t), pointer :: cp + call handle_to_cp(handle, cp) + get_cond_dimc = cp%dimC + end function get_cond_dimc + + integer(c_int) function get_cond_dimx(handle) bind(C, name="get_cond_dimx_") + integer(c_intptr_t), value :: handle + type(cond_profiles_t), pointer :: cp + call handle_to_cp(handle, cp) + get_cond_dimx = cp%dimx + end function get_cond_dimx + + function get_cond_x_ptr(handle) result(ptr) bind(C, name="get_cond_x_ptr_") + integer(c_intptr_t), value :: handle + type(c_ptr) :: ptr + type(cond_profiles_t), pointer :: cp + call handle_to_cp(handle, cp) + ptr = c_loc(cp%x(0)) + end function get_cond_x_ptr + + function get_cond_k_ptr(handle) result(ptr) bind(C, name="get_cond_k_ptr_") + integer(c_intptr_t), value :: handle + type(c_ptr) :: ptr + type(cond_profiles_t), pointer :: cp + call handle_to_cp(handle, cp) + ptr = c_loc(cp%K(0)) + end function get_cond_k_ptr + + integer(c_int) function get_cond_iks(handle, spec, ttype, p, q, i, j, part, node) & + bind(C, name="get_cond_iks_") + integer(c_intptr_t), value :: handle + integer(c_int), value :: spec, ttype, p, q, i, j, part, node + type(cond_profiles_t), pointer :: cp + call handle_to_cp(handle, cp) + get_cond_iks = iKs(cp, spec, ttype, p, q, i, j, part, node) + end function get_cond_iks + + function get_cond_flag_back(handle) result(ch) bind(C, name="get_cond_flag_back_") + integer(c_intptr_t), value :: handle + character(kind=c_char) :: ch + type(cond_profiles_t), pointer :: cp + call handle_to_cp(handle, cp) + ch = cp%flag_back(1:1) + end function get_cond_flag_back + + subroutine get_cond_path2linear(handle, buf) bind(C, name="get_cond_path2linear_") + integer(c_intptr_t), value :: handle + character(kind=c_char), intent(out) :: buf(*) + type(cond_profiles_t), pointer :: cp + integer :: i, n + + call handle_to_cp(handle, cp) + n = len_trim(cp%path2linear) + do i = 1, n + buf(i) = cp%path2linear(i:i) + end do + buf(n + 1) = c_null_char + end subroutine get_cond_path2linear + + subroutine handle_to_cp(handle, cp) + integer(c_intptr_t), value :: handle + type(cond_profiles_t), pointer, intent(out) :: cp + type(c_ptr) :: ccp + ccp = transfer(handle, ccp) + call c_f_pointer(ccp, cp) + end subroutine handle_to_cp + + subroutine read_c_string(cp_, out) + type(c_ptr), value :: cp_ + character(len=*), intent(out) :: out + character(kind=c_char), pointer :: chars(:) + integer :: i + + call c_f_pointer(cp_, chars, [len(out)]) + out = '' + do i = 1, len(out) + if (chars(i) == c_null_char) exit + out(i:i) = chars(i) + end do + end subroutine read_c_string + +end module kilca_cond_profiles_m diff --git a/KiLCA/flre/conductivity/cond_profs_pol.cpp b/KiLCA/flre/conductivity/cond_profs_pol.cpp deleted file mode 100644 index 46b4bc5f..00000000 --- a/KiLCA/flre/conductivity/cond_profs_pol.cpp +++ /dev/null @@ -1,279 +0,0 @@ -/*! \file cond_profs_pol.cpp - \brief The implementation of functions declared in cond_profs.h (version with polynomial interpolation used to generate adaptive radial grid). -*/ - -#include -#include -#include -#include -#include - -#include "cond_profs.h" -#include "calc_cond.h" -#include "core.h" -#include "calc_back.h" -#include "shared.h" -#include "adaptive_grid_pol.h" -#include "flre_zone.h" - -/*******************************************************************/ - -void alloc_conductivity_profiles_ (cond_profiles **cpptr) -{ -cond_profiles *cp = new cond_profiles; -*cpptr = cp; -} - -/*******************************************************************/ - -void cond_profiles::calc_and_spline_main_conductivity_profiles (const flre_zone *zone, int flag) -{ -sd = zone->get_settings (); -bp = zone->get_background (); -wd = zone->get_wave_data (); - -r1 = zone->r1; -r2 = zone->r2; - -D = zone->D; -eps_out = zone->eps_out; -eps_res = zone->eps_res; - -flag_back = new char[8]; -strcpy (flag_back, sd->bs->flag_back); - -path2linear = new char[1024]; - -eval_path_to_linear_data (zone->get_path_to_project(), wd->m, wd->n, wd->olab, path2linear); - -flreo = zone->flre_order; - -gal_corr = zone->gal_corr; - -NK = zone->N + flreo + 1; //splines degree for K matrices in rsp - odd! - -//binomial coefficients: -bico = new double[(flreo+1)*(flreo+1)]; - -binomial_coefficients (flreo, bico); - -//conductivity K profiles: spec=0:1, [type=0:dimt-1, p=0:flreo, q=0:flreo, i=0:2, j=0:2], (re, im) -dimt = 2; //2 types of K matrices -dimK = 2*(dimt)*(flreo+1)*(flreo+1)*3*3*2; - -//arrays for temp adaptive grid: -dimx = zone->max_dim_c; - -xt = new double[dimx]; -yt = new double[dimK*dimx]; - -double a = max (r1-1.0, bp->x[0]); -double b = min (r2+1.0, bp->x[bp->dimx-1]); - -if (a > r1 || b < r2) -{ - fprintf (stdout, "\nwarning: a or b is inside the zone.\n"); - fflush (stdout); - exit(1); -} - -//indices for error control: -int l = 0, pmax = 0, qmax = 0; -int dim_err = 2*(pmax+1)*(qmax+1)*3*3*2; -int *ind_err = new int[dim_err]; - -for (int spec=0; spec<2; spec++) -{ - for (int type=0; type<1; type++) - { - for (int p=0; p<=pmax; p++) - { - for (int q=0; q<=qmax; q++) - { - for (int i=0; i<3; i++) - { - for (int j=0; j<3; j++) - { - for (int part=0; part<2; part++) - { - ind_err[l++] = iKa (spec, type, p, q, i, j, part, 0); - } - } - } - } - } - } -} - -if (l != dim_err) -{ - fprintf (stderr, "\nerror: wrong dimension of ind_err array: %d != %d", dim_err, l); -} - -double epso = eps_out; -double epsi = eps_res; - -//adaptive_grid_polynom (sample_cond_func_polynom, (void *)this, a, b, dimK, NK, &dimx, &epso, dim_err, ind_err, xt, yt); - -adaptive_grid_polynom_res (sample_cond_func_polynom, (void *)this, a, b, dimK, NK, &dimx, &epso, wd->r_res, D, epsi, dim_err, ind_err, xt, yt); - -delete [] ind_err; - -//correct dimension dimx: -x = new double[dimx]; -K = new double[(dimx)*(dimK)]; -CK = new double[(dimx)*(dimK)*(NK+1)]; -RK = new double[(NK+1)*(dimK)]; - -if (flag == 0) -{ - calc_splines_for_K_polynom (this); -} -else -{ - set_arrays_for_K_polynom (this); -} - -delete [] xt; -delete [] yt; - -if (zone->flag_debug > 1) -{ - save_K_matrices (this, -1, 0); //spec, type - - //save_K_matrices_fine (this, -1, 0, 10); //spec, type -} - -if (flag) return; - -NC = zone->N; //splines degree for C matrices - -/*conductivity C profiles: spec=0:1, [type=0:dimt-1,s=0..2flreo, i=0:2, j=0:2], (re, im)*/ -dimC = 2*dimt*(2*flreo+1)*3*3*2; -C = new double[dimx*dimC]; -CC = new double[(NC+1)*dimx*dimC]; -RC = new double[(NC+1)*dimC]; - -calc_splines_for_C (this); - -if (zone->flag_debug > 1) -{ - save_C_matrices (this, -1, 0); //spec, type - - //save_C_matrices_fine (this, -1, 0, 5); //spec, type -} -} - -/*******************************************************************/ - -void delete_conductivity_profiles_f_ (cond_profiles **cp_ptr) -{ -delete *cp_ptr; -} - -/*******************************************************************/ - -void calc_and_spline_conductivity_for_point_ (settings **sd_ptr, background **bp_ptr, - wave_data **wd_ptr, char *flag_back, - double *r, cond_profiles **cp_ptr) -{ -//it is assumed that flre_sett and all other fortran modules are set properly! - -alloc_conductivity_profiles_ (cp_ptr); - -cond_profiles *cp = (cond_profiles *)(*cp_ptr); - -cp->sd = (const settings *) (*sd_ptr); -cp->bp = (const background *)(*bp_ptr); -cp->wd = (const wave_data *) (*wd_ptr); - -cp->flag_back = new char[8]; -cp->flag_back[0] = flag_back[0]; - -cp->path2linear = NULL; //not needed in this case - -get_flre_order_ (&(cp->flreo)); - -get_gal_corr_ (&(cp->gal_corr)); - -//binomial coefficients: -cp->bico = new double[(cp->flreo+1)*(cp->flreo+1)]; - -binomial_coefficients (cp->flreo, cp->bico); - -cp->NK = cp->sd->bs->N - (cp->flreo + 1); //flreo is assumed to be odd - -cp->dimt = 2; //2 types of K matrices -cp->dimK = 2*(cp->dimt)*(cp->flreo+1)*(cp->flreo+1)*3*3*2; - -cp->dimx = 3*(cp->NK + 1); //minimum possible dimension for splines - -cp->xt = new double[(cp->dimx)]; -cp->yt = new double[(cp->dimx)*(cp->dimK)]; - -//interval for splining around point *r: -double delta = 0.01*(cp->bp->x[cp->bp->dimx-1] - cp->bp->x[0]); //interval width -double a = fmax(cp->bp->x[0], *r-delta); //left boundary -double b = fmin(cp->bp->x[cp->bp->dimx-1], *r+delta); //right boundary - -//indices for error control: -int l = 0, pmax = 0, qmax = 0; -int dim_err = 2*(pmax+1)*(qmax+1)*3*3*2; -int *ind_err = new int[dim_err]; - -for (int spec=0; spec<2; spec++) -{ - for (int type=0; type<1; type++) - { - for (int p=0; p<=pmax; p++) - { - for (int q=0; q<=qmax; q++) - { - for (int i=0; i<3; i++) - { - for (int j=0; j<3; j++) - { - for (int part=0; part<2; part++) - { - ind_err[l++] = cp->iKa (spec, type, p, q, i, j, part, 0); - } - } - } - } - } - } -} - -if (l != dim_err) -{ - fprintf (stderr, "\nerror: wrong dimension of ind_err array: %d != %d", dim_err, l); -} - -double eps = 0.0e0; - -adaptive_grid_polynom (sample_cond_func_polynom, (void *)cp, a, b, cp->dimK, cp->NK, &(cp->dimx), &eps, dim_err, ind_err, cp->xt, cp->yt); - -delete [] ind_err; - -//correct dimension dimx: -cp->x = new double[cp->dimx]; -cp->K = new double[(cp->dimx)*(cp->dimK)]; -cp->CK = new double[(cp->dimx)*(cp->dimK)*(cp->NK+1)]; -cp->RK = new double[(cp->NK+1)*(cp->dimK)]; - -calc_splines_for_K_polynom (cp); - -delete [] cp->xt; -delete [] cp->yt; - -/*conductivity C profiles: spec=0:1, [type=0:dimt-1,s=0..2flreo, i=0:2, j=0:2], (re, im)*/ -cp->NC = cp->NK - (cp->flreo + 1); //flreo is assumed to be odd -cp->dimC = 2*(cp->dimt)*(2*(cp->flreo)+1)*3*3*2; -cp->C = new double[(cp->dimx)*(cp->dimC)]; -cp->CC = new double[(cp->NC+1)*(cp->dimx)*(cp->dimC)]; -cp->RC = new double[(cp->NC+1)*(cp->dimC)]; - -calc_splines_for_C (cp); -} - -/*******************************************************************/ diff --git a/KiLCA/flre/conductivity/conduct_parameters.h b/KiLCA/flre/conductivity/conduct_parameters.h deleted file mode 100644 index 1bee75a3..00000000 --- a/KiLCA/flre/conductivity/conduct_parameters.h +++ /dev/null @@ -1,38 +0,0 @@ -/*! \file conduct_parameters.h - \brief The C declarations of Fortran subroutines used in evaluation of conductivity matrices. -*/ - -#ifndef CONDUCT_PARAMETERS_INCLUDE - -#define CONDUCT_PARAMETERS_INCLUDE - -extern "C" -{ -void set_back_aliases_in_conductivity_parameters_ (); - -void eval_and_set_conduct_parameters_spec_independent_ (double *r, char *flag_back, int len); -void eval_and_set_conduct_parameters_spec_dependent_ (double *r, int *spec, char *flag_back, int len); -void eval_and_set_all_conduct_parameters_ (double *r, int *spec, char *flag_back, int len); - -void eval_and_set_background_parameters_spec_independent_ (double *r, char *flag_back, int len); -void eval_and_set_wave_parameters_ (double *r, char *flag_back, int len); - -void eval_and_set_background_parameters_spec_dependent_ (double *r, int *spec, char *flag_back, int len); -void eval_and_set_f0_parameters_nu_and_derivs_ (double *r, int *spec, char *flag_back, int len); - -void print_conduct_params_ (void); -void print_conduct_arrays_ (void); - -void eval_z_and_oms_ (void); -void eval_w_array_ (void); - -void get_wave_parameters_ (double *kvals); - -//from conductivity_arrays: -void allocate_and_set_conductivity_arrays_ (void); -void eval_electric_drift_velocities_ (void); -void eval_FGI_arrays_ (void) ; -void eval_A_matrix_ (void); -} - -#endif diff --git a/KiLCA/flre/conductivity/eval_cond.cpp b/KiLCA/flre/conductivity/eval_cond.cpp deleted file mode 100644 index f8c81eb1..00000000 --- a/KiLCA/flre/conductivity/eval_cond.cpp +++ /dev/null @@ -1,119 +0,0 @@ -/*! \file eval_cond.cpp - \brief The implementation of functions declared in eval_cond.h. -*/ - -#include -#include -#include -#include - -#include "eval_cond.h" -#include "cond_profs.h" -#include "spline.h" - -/*******************************************************************/ - -void eval_K_matrices (const cond_profiles *cp, int spec, int type, int Dmin, int Dmax, double r, double *K) -{ -int dimk = 2*9*(cp->flreo+1)*(cp->flreo+1); //number of K's to eval -int ind_ka = cp->iKa(spec, type, 0, 0, 0, 0, 0, 0); - -spline_eval_d_ (cp->sidK, 1, &r, Dmin, Dmax, ind_ka, ind_ka+dimk-1, K); - -if (cp->flag_back[0] != 'f') //r is multiplied on huge_factor -{ - for (int n=Dmin; n<=Dmax; n++) - { - double scale_fac = pow (cp->sd->bs->huge_factor, n); - int ind = dimk*(n-Dmin); - for (int j=0; jdimK; //number of K's to eval - -spline_eval_d_ (cp->sidK, 1, &r, Dmin, Dmax, 0, dimk-1, K); - -int n, j, ind; -double scale_fac; - -if (cp->flag_back[0] != 'f') //r is multiplied on a huge_factor -{ - for (n=Dmin; n<=Dmax; n++) - { - scale_fac = pow (cp->sd->bs->huge_factor, n); - ind = dimk*(n-Dmin); - for (j=0; jflreo)+1); //number of C's to eval -int ind_ca = dimc*(type + (cp->dimt)*spec); - -spline_eval_d_ (cp->sidC, 1, &r, Dmin, Dmax, ind_ca, ind_ca+dimc-1, C); - -int n, j, ind; -double scale_fac; - -if (cp->flag_back[0] != 'f') //r is multiplied on huge_factor -{ - for (n=Dmin; n<=Dmax; n++) - { - scale_fac = pow (cp->sd->bs->huge_factor, n); - ind = dimc*(n-Dmin); - for (j=0; jdimC; //number of C's to eval - -spline_eval_d_ (cp->sidC, 1, &r, Dmin, Dmax, 0, dimc-1, C); - -int n, j, ind; -double scale_fac; - -if (cp->flag_back[0] != 'f') //r is multiplied on huge_factor -{ - for (n=Dmin; n<=Dmax; n++) - { - scale_fac = pow (cp->sd->bs->huge_factor, n); - ind = dimc*(n-Dmin); - for (j=0; j -#include - -#include "fortnum.h" - -#include "constants.h" - -#include -#include - -/*******************************************************************/ - -extern "C" -{ -int calc_imnl_quad_ (int * m_max, int * n_max, int * l_max, - double * x1_re, double * x1_im, - double * x2_re, double * x2_im, - double * x3_re, double * x3_im, - double * x4_re, double * x4_im, - double * Imnl); -} - -/*******************************************************************/ - -struct quad_params -{ - complex x1; - complex x2; - complex x3; - complex x4; - - int l; - - complex gamma; - - double x; - double y; - - int part; -}; - -/*******************************************************************/ - -double subint (double tau, void * params) -{ -quad_params * p = static_cast(params); - -complex gme = (p->gamma) - E; - -complex ExP = std::exp(-tau); - -complex gExP = (p->gamma)*ExP; - -complex gExP2 = gExP*gExP; - -complex den = gme*gme - gExP2; - -complex r2 = (p->x)*(p->x) + (p->y)*(p->y); - -complex ans = - sqrt2pi / pow(E + (p->x4)*tau*I, (p->l)+1) / sqrt(den) * - - exp( (-(p->x1)*(p->x1) + (p->x2)*I)*tau + - - (E - ExP) / (gme + gExP) * (p->x1) * ((2.0*(p->gamma) - 1.0)*(p->x1) + ((p->x) + (p->y))*I) + - - (r2*(gExP*ExP - gme) + 2.0e0*(p->x)*(p->y)*ExP) / 2.0e0 / den); - -//std::cout << "tau=" << tau << std::endl; - -//std::cout << "pow=" << pow(E + (p->x4)*tau*I, (p->l)+1) << std::endl; - -//std::cout << "arg=" << (-(p->x1)*(p->x1) + (p->x2)*I)*tau + -// -// (E - ExP) / (gme + gExP) * (p->x1) * ((2.0*(p->gamma) - 1.0)*(p->x1) + ((p->x) + (p->y))*I) + -// -// (r2*(gExP*ExP - gme) + 2.0e0*(p->x)*(p->y)*ExP) / 2.0e0 / den << std::endl; - -//std::cout << ans << std::endl; - -if (p->part == 0) return real(ans); -else return imag(ans); -} - -/*******************************************************************/ - -int calc_imnl_quad_ (int * m_max, int * n_max, int * l_max, - double * x1_re, double * x1_im, - double * x2_re, double * x2_im, - double * x3_re, double * x3_im, - double * x4_re, double * x4_im, - double * Imnl) -{ -complex x1(*x1_re, *x1_im); -complex x2(*x2_re, *x2_im); -complex x3(*x3_re, *x3_im); -complex x4(*x4_re, *x4_im); - -//bar x* values: -complex alpha = sqrt(0.25e0*E - x3*I) - 0.5e0*E; - -complex ep2a = E + 2.0e0*alpha; - -complex gamma = alpha / ep2a; - -x1 = x1 / pow(ep2a, 1.5e0); - -x2 = x2 / ep2a + gamma * I; - -x4 = x4 / ep2a; - -quad_params qp = {x1, x2, x3, x4, 0, gamma, 0, 0, 0}; - -double epsabs = 1.0e-14, epsrel = 1.0e-14, err; - -double x = 0.0; -double y = 0.0; - -int m = 0, n = 0; - -complex InT; - -double tmax = 4.0e1; -double step = std::min(tmax, 1.0e2/std::abs(I*x2-x1*x1)); -double t1 = 0.0e0, t2 = step; - -std::cout << step; - -for(int l = 0; l <= *l_max; ++l) -{ - qp.l = l; - qp.x = x; - qp.y = y; - - int ind = 2 * (m + (*m_max+1) * (n + (*n_max+1) * (l))); - - Imnl[ind+0] = 0.0e0; - Imnl[ind+1] = 0.0e0; - - while(t2 <= tmax) - { - double I_re; - qp.part = 0; - fortnum_integrate_qag(&subint, t1, t2, epsabs, epsrel, 21, &I_re, &err, &qp); - - double I_im; - qp.part = 1; - fortnum_integrate_qag(&subint, t1, t2, epsabs, epsrel, 21, &I_im, &err, &qp); - - InT = (I_re + I_im * I) / pow(ep2a, 0.5e0*(3 + m + n)); - - Imnl[ind+0] += real(InT); - Imnl[ind+1] += imag(InT); - - t1 = t2; - t2 += step; - } -} - -return 0; -} - -/*******************************************************************/ diff --git a/KiLCA/flre/dispersion/disp_profs.cpp b/KiLCA/flre/dispersion/disp_profs.cpp deleted file mode 100644 index c2cb02d4..00000000 --- a/KiLCA/flre/dispersion/disp_profs.cpp +++ /dev/null @@ -1,265 +0,0 @@ -/*! \file disp_profs.cpp - \brief The implementation of disp_profiles class. -*/ - -#include -#include -#include -#include -#include -#include - -#include "code_settings.h" - -#include "disp_profs.h" -#include "shared.h" -#include "inout.h" - -/*******************************************************************/ - -disp_profiles::disp_profiles (int Nw, int dimx_p, double * x_p, const char * flag_back_p) -{ -Nwaves = Nw; - -dimx = dimx_p; -x = x_p; - -flag_back = new char[8]; -strcpy (flag_back, flag_back_p); - -dimk = 2*Nwaves; -k = new double[(dimk)*(dimx)]; - -dimp = 2*(Nwaves)*(Nwaves); -p = new double[(dimp)*(dimx)]; - -S = 0; -R = 0; -sid = 0; -} - -/*******************************************************************/ - -void disp_profiles::calculate_dispersion_profiles (void) -{ -int f = 0; - -for (int i=0; i min1) min2 = dst; - } - - if (min2 < 1.0e1*min1) - { - fprintf (stdout, "\nsort_dispersion_profiles: warning: min1 = %lg min2 = %lg j = %d ind = %d", min1, min2, j, ind[j]); - } - } - - //rearranging eigenvalues and vectors to form continious curves: - for (j=0; j - -#include "spline.h" - -/*! \class disp_profiles - \brief Class stores various data related to dispersion profiles. -*/ -class disp_profiles -{ -public: - int Nwaves; //! Dispersion-relation profiles for a flre_zone, formerly the C++ disp_profiles +!> class. Per-instance handle (same pattern as kilca_spline_m/ +!> kilca_maxwell_eqs_data_m), since each flre_zone owns its own instance. +!> +!> calculate_dispersion_profiles drives the existing Fortran calc_dispersion +!> subroutine (called natively here, exactly as it is from other Fortran code, +!> so the gfortran hidden-string-length convention for the flagback argument is +!> handled by the compiler automatically -- not via the old C ABI's manual +!> trailing-length argument). +!> +!> sort_dispersion_profiles is NOT translated: SORT_DISPERSION_PROFILES is +!> hard-coded to 0 in CMakeLists.txt, so the C++ #if SORT_DISPERSION_PROFILES +!> == 1 branch calling it was dead code in the active build. +module kilca_disp_profiles_m + use, intrinsic :: iso_c_binding, only: c_int, c_intptr_t, c_char, c_double, & + c_ptr, c_null_ptr, c_loc, c_f_pointer + use, intrinsic :: iso_fortran_env, only: dp => real64 + implicit none + private + + public :: disp_profiles_create, disp_profiles_destroy + public :: disp_profiles_calculate, disp_profiles_save + + type :: disp_profiles_t + integer(c_int) :: Nwaves + character(len=1) :: flag_back + integer(c_int) :: dimx + type(c_ptr) :: x_ptr = c_null_ptr + integer(c_int) :: dimk + real(c_double), allocatable :: k(:) + integer(c_int) :: dimp + real(c_double), allocatable :: p(:) + end type disp_profiles_t + + interface + subroutine calc_dispersion(r, flagback, flagprint, kval, polvec) + import :: dp + real(dp), intent(in) :: r + character(*), intent(in) :: flagback + integer, intent(in) :: flagprint + real(dp), intent(out) :: kval(*) + real(dp), intent(out) :: polvec(*) + end subroutine calc_dispersion + + function save_cmplx_matrix_to_one_file(Nrows, Ncols, Npoints, xgrid, arr, full_name) & + result(ierr) bind(C, name="save_cmplx_matrix_to_one_file") + import :: c_int, c_double, c_char + integer(c_int), value :: Nrows, Ncols, Npoints + real(c_double), intent(in) :: xgrid(*) + real(c_double), intent(in) :: arr(*) + character(kind=c_char), intent(in) :: full_name(*) + integer(c_int) :: ierr + end function save_cmplx_matrix_to_one_file + end interface + +contains + + function disp_profiles_create(Nw, dimx_p, x_p, flag_back_p) result(handle) & + bind(C, name="disp_profiles_create_") + integer(c_int), value :: Nw, dimx_p + type(c_ptr), value :: x_p + type(c_ptr), value :: flag_back_p + integer(c_intptr_t) :: handle + type(disp_profiles_t), pointer :: d + character(kind=c_char), pointer :: fb + + allocate (d) + d%Nwaves = Nw + d%dimx = dimx_p + d%x_ptr = x_p + + call c_f_pointer(flag_back_p, fb) + d%flag_back = fb + + d%dimk = 2*Nw + allocate (d%k(d%dimk*dimx_p)) + + d%dimp = 2*Nw*Nw + allocate (d%p(d%dimp*dimx_p)) + + handle = transfer(c_loc(d), handle) + end function disp_profiles_create + + subroutine disp_profiles_destroy(handle) bind(C, name="disp_profiles_destroy_") + integer(c_intptr_t), value :: handle + type(disp_profiles_t), pointer :: d + + if (handle == 0_c_intptr_t) return + call handle_to_d(handle, d) + if (allocated(d%k)) deallocate (d%k) + if (allocated(d%p)) deallocate (d%p) + deallocate (d) + end subroutine disp_profiles_destroy + + subroutine disp_profiles_calculate(handle) bind(C, name="disp_profiles_calculate_") + integer(c_intptr_t), value :: handle + type(disp_profiles_t), pointer :: d + real(c_double), pointer :: x(:) + integer(c_int) :: i + + call handle_to_d(handle, d) + call c_f_pointer(d%x_ptr, x, [d%dimx]) + + do i = 0, d%dimx - 1 + call calc_dispersion(x(i + 1), d%flag_back, 0, & + d%k(d%dimk*i + 1:), d%p(d%dimp*i + 1:)) + end do + end subroutine disp_profiles_calculate + + subroutine disp_profiles_save(handle, filename) bind(C, name="disp_profiles_save_") + integer(c_intptr_t), value :: handle + type(c_ptr), value :: filename + type(disp_profiles_t), pointer :: d + real(c_double), pointer :: x(:) + character(kind=c_char), pointer :: fname(:) + integer(c_int) :: ierr + + call handle_to_d(handle, d) + call c_f_pointer(d%x_ptr, x, [d%dimx]) + call c_f_pointer(filename, fname, [1024]) + + ierr = save_cmplx_matrix_to_one_file(d%Nwaves, 1, d%dimx, x, d%k, fname) + end subroutine disp_profiles_save + + subroutine handle_to_d(handle, d) + integer(c_intptr_t), value :: handle + type(disp_profiles_t), pointer, intent(out) :: d + type(c_ptr) :: cp + cp = transfer(handle, cp) + call c_f_pointer(cp, d) + end subroutine handle_to_d + +end module kilca_disp_profiles_m diff --git a/KiLCA/flre/flre_zone.cpp b/KiLCA/flre/flre_zone.cpp deleted file mode 100644 index 28ac59b0..00000000 --- a/KiLCA/flre/flre_zone.cpp +++ /dev/null @@ -1,1213 +0,0 @@ -/*! \file flre_zone.cpp - \brief The implementation of flre_zone class. -*/ - -#include "flre_zone.h" -#include "mode.h" -#include "shared.h" -#include "inout.h" -#include "eval_back.h" -#include "adaptive_grid_pol.h" -#include "rhs_func.h" -#include "solver.h" -#include "transforms.h" -#include "typedefs.h" -#include "calc_flre_quants.h" - -/*****************************************************************************/ - -void flre_zone::read_settings (char * file) -{ -read (file); //base class read function - -//derived class specific: -FILE *in; - -if ((in=fopen (file, "r"))==NULL) -{ - fprintf(stderr, "\nerror: hmedium_zone: read_settings: failed to open file %s\a\n", file); - exit(0); -} - -char *str_buf = new char[1024]; - -//skip lines (already readed and values are set): -read_line_2skip_it (in, &str_buf); -read_line_2skip_it (in, &str_buf); -read_line_2skip_it (in, &str_buf); -read_line_2skip_it (in, &str_buf); -read_line_2skip_it (in, &str_buf); -read_line_2skip_it (in, &str_buf); -read_line_2skip_it (in, &str_buf); -read_line_2skip_it (in, &str_buf); - -read_line_2skip_it (in, &str_buf); -read_line_2get_int (in, &(flre_order)); -read_line_2get_int (in, &(Nmax)); -read_line_2get_int (in, &(gal_corr)); -read_line_2get_int (in, &(N)); -read_line_2get_int (in, &(max_dim_c)); -read_line_2get_double (in, &(D)); -read_line_2get_double (in, &(eps_out)); -read_line_2get_double (in, &(eps_res)); -read_line_2get_int (in, &(hom_sys)); -read_line_2skip_it (in, &str_buf); - -//ODE solver settings: -read_line_2skip_it (in, &str_buf); -read_line_2get_int (in, &(max_dim)); -read_line_2get_double (in, &(eps_rel)); -read_line_2get_double (in, &(eps_abs)); -read_line_2get_int (in, &(Nort)); -read_line_2get_double (in, &(norm_fac)); -read_line_2get_double (in, &(dr_out)); -read_line_2get_double (in, &(dr_res)); -read_line_2get_double (in, &(del)); -read_line_2skip_it (in, &str_buf); - -//Space out settings: -read_line_2skip_it (in, &str_buf); -read_line_2get_int (in, &(deg)); -read_line_2get_double (in, &(reps)); -read_line_2get_double (in, &(aeps)); -read_line_2get_double (in, &(step)); -read_line_2skip_it (in, &str_buf); - -//Debugging settings: -read_line_2skip_it (in, &str_buf); -read_line_2get_int (in, &(flag_debug)); -read_line_2skip_it (in, &str_buf); - -//Collisions model flag: -read_line_2skip_it (in, &str_buf); -read_line_2get_int (in, &(collmod[0])); -read_line_2get_int (in, &(collmod[1])); -read_line_2skip_it (in, &str_buf); - -fclose (in); - -delete [] str_buf; - -if (hom_sys != 0) -{ - fprintf (stdout, "warning: homogenious limit should not be normally used."); - exit (1); -} - -Nwaves = 6*flre_order - 2; -Ncomps = 6*flre_order + 7; - -if (bc1 == BOUNDARY_CENTER || bc1 == BOUNDARY_IDEALWALL || - bc2 == BOUNDARY_INFINITY || bc2 == BOUNDARY_IDEALWALL) -{ - Nfs = Nwaves/2; -} -else -{ - Nfs = Nwaves; -} - -if (flag_debug) print_settings (); -} - -/*****************************************************************************/ - -void flre_zone::print_settings (void) -{ -print (); //base class print function - -fprintf(stdout, "\nCheck for flre specific settings below:\n"); - -fprintf (stdout, "\norder of FLR expansion: %d", flre_order); -fprintf (stdout, "\nhighest cyclotron harmonic: %d", Nmax); -fprintf (stdout, "\nflag if to use correction term in conductivity: %d", gal_corr); -fprintf (stdout, "\nsplines degree: %d", N); -fprintf (stdout, "\nmaximum dimension of the grid for conductivity martices: %d", max_dim_c); -fprintf (stdout, "\nresonant layer width: %le", D); -fprintf (stdout, "\nerror parameter used for adaptive radial grid outside the resonant layer: %le", eps_out); -fprintf (stdout, "\nerror parameter used for the adaptive radial grid in the resonant layer: %le", eps_res); - -fprintf (stdout, "\nflag for homogenious system: %d", hom_sys); -fprintf (stdout, "\nmax number of orthonormalization steps (ONS) for the solver: %d", Nort); -fprintf (stdout, "\ncontrolling factor for ONS by QR: %lg", norm_fac); -fprintf (stdout, "\noutput grid step outside the resonance region for the ME solutions: %lg", dr_out); -fprintf (stdout, "\noutput grid step inside the resonance region for the ME solutions: %lg", dr_res); -fprintf (stdout, "\nwidth of the resonance region: %lg", del); - -fprintf (stdout, "\ncollisions model flags: %d %d", collmod[0], collmod[1]); - -fprintf(stdout, "\n"); -} - -/*****************************************************************************/ - -void flre_zone::calc_basis_fields (int flag) -{ - flre_zone *pointer = this; - - if (flag) rsp = 0; else rsp = 1; - - setup_flre_data_module_ (&pointer); - - //calculates various data related to maxwell equations: - calc_and_set_maxwell_system_parameters_module_ (); - - me = new maxwell_eqs_data (Nwaves); - - copy_module_data_to_maxwell_eqs_data_struct (me); - - if (flag_debug) me->print (); - - allocate_and_set_conductivity_arrays_ (); - - cp = new cond_profiles; - - set_cond_profiles_in_mode_data_module_ (&cp); - - cp->calc_and_spline_main_conductivity_profiles (this, flag); - - if (flag) - { - deallocate_conductivity_arrays_ (); - - clean_maxwell_system_parameters_module_ (); - - clean_flre_data_module_ (); - - return; - } - - //allocates and calculates system matrix: - sp = new sysmat_profiles; - - set_sysmat_profiles_in_mode_data_module_ (&sp); - - sp->calc_and_spline_sysmatrix_profiles (this); - - - //calc dispersion if needed: - if (sd->os->flag_dispersion > 1) - { - calc_dispersion (); - save_dispersion (); - } - calculate_field_profiles_orth (); - - //cleaning: - deallocate_conductivity_arrays_ (); - - clean_maxwell_system_parameters_module_ (); - - clean_flre_data_module_ (); - - //transform basis to the lab frame: - //this is done later after spacing out, together with the evaluation of the full system - //vector, and the transformation to the lab frame. - //for stitching equations, fields (state vector) in the moving frame are used. - //check for consistency flre.f90! -} - -/*****************************************************************************/ - -void flre_zone::copy_E_and_B_fields (double *EB_p) -{ -complex EBrsp[6], EBcyl[6]; - -for (int node=0; nodehom_sys; - -*Nwaves = zone->Nwaves; - -*Nfs = zone->Nfs; - -*Nphys = 0; - -*flag_debug = zone->flag_debug; -} - -/*****************************************************************************/ - -void set_conductivity_settings_c_ (flre_zone **ptr, int *flre_order, int *Nmax, int *gal_corr, int *rsp) -{ -flre_zone *zone = (flre_zone *)(*ptr); - -*flre_order = zone->flre_order; - -*Nmax = zone->Nmax; - -*gal_corr = zone->gal_corr; - -*rsp = zone->rsp; -} - -/*****************************************************************************/ - -void set_collisions_settings_c_ (flre_zone **ptr, int *collmod) -{ -flre_zone *zone = (flre_zone *)(*ptr); - -collmod[0] = zone->collmod[0]; -collmod[1] = zone->collmod[1]; -} - -/*****************************************************************************/ - -void flre_zone::calculate_field_profiles_orth (void) -{ - double *y = new double[2*Nwaves*Nwaves]; //state vectors at a point - - int ind1 = 0, ind2 = 0; - - double ri, rf; //initial and final r values for integration - - if (bc1 == BOUNDARY_CENTER) - { - ri = r1; - rf = r2; - - //calc_start_values_anywhere_low_derivs_ (&ri, y); - calc_start_values_center_with_correct_asymptotic_ (&ri, y); - - Nfs = Nwaves/2; - ind1 = 0; //min index of a fundamental solution which is regular at the boundary - ind2 = Nfs-1; //max index of a fundamental solution which is regular at the boundary - } - else if (bc1 == BOUNDARY_IDEALWALL) - { - ri = r1; - rf = r2; - - calc_start_values_anywhere_low_derivs_ (&ri, y); - //calc_start_values_ideal_wall_without_fake_modes_ (&ri, y); - - Nfs = Nwaves/2; - ind1 = 0; //min index of a fundamental solution which is regular at the boundary - ind2 = Nfs-1; //max index of a fundamental solution which is regular at the boundary - } - else if (bc2 == BOUNDARY_INFINITY) - { - ri = r2; - rf = r1; - - //calc_start_values_anywhere_low_derivs_ (&ri, y); - //calc_start_values_infinity_without_fake_modes_ (&ri, y); - - Nfs = Nwaves/2; - ind1 = Nfs; //min index of a fundamental solution which is regular at the boundary - ind2 = Nwaves-1; //max index of a fundamental solution which is regular at the boundary - - fprintf (stdout, "\nflre_zone::calculate_field_profiles_orth: not implemented!"); - exit (1); - } - else if (bc2 == BOUNDARY_IDEALWALL) - { - ri = r2; - rf = r1; - - calc_start_values_anywhere_low_derivs_ (&ri, y); - //calc_start_values_ideal_wall_without_fake_modes_ (&ri, y); - - Nfs = Nwaves/2; - ind1 = 0; //min index of a fundamental solution which is regular at the boundary - ind2 = Nfs-1; //max index of a fundamental solution which is regular at the boundary - } - else - { - //general case: - ri = r1; - rf = r2; - - //calc_start_values_general_without_fake_modes_ (&ri, y); - - Nfs = Nwaves; - ind1 = 0; //min index of a fundamental solution which is regular at the boundary - ind2 = Nwaves-1; //max index of a fundamental solution which is regular at the boundary - - fprintf (stdout, "\nflre_zone::calculate_field_profiles_orth: unknown BCs!"); - exit (1); - } - - //number of equations without an approximation for short modes: - int Neq = 2*Nwaves*Nfs; - - //radial grid generation for a zone with resonance: - double *grid; - - double sgn = signum(rf-ri); - - if (r1 <= wd->r_res && r2 >= wd->r_res) - { - double r_res = wd->r_res; - - double r = ri; - - int node = 0; - - while ((r-rf)*sgn < 0) - { - r += ((dr_out-dr_res)*(1.0 - exp(-(r-r_res)*(r-r_res)/del/del)) + dr_res)*sgn; - node++; - } - - dim = node+1; //last point should be replaced by rf - - grid = new double[dim]; - - r = ri; - - node = 0; - while ((r-rf)*sgn < 0) - { - grid[node++] = r; - - r += ((dr_out-dr_res)*(1.0 - exp(-(r-r_res)*(r-r_res)/del/del)) + dr_res)*sgn; - } - - grid[node] = rf; - } - else - { - dim = (int) abs(rf-ri)/dr_out; - - grid = new double[dim]; - - double dr = (rf - ri)/(dim-1); - - for (int node=0; nodebs->V_gal_sys, wd->olab, ri, - &y[2*Nwaves*j], &state[2*Nwaves*j]); - } - - //settings for solver: - double *Dmat = new double[2*Nwaves*(Nwaves + 2*Nfs)]; - - rhs_func_params params = {Nwaves, Nwaves, Nfs, Dmat, sp}; - - solver_settings ss = {Nort, eps_rel, eps_abs, norm_fac, flag_debug}; - - integrate_basis_vecs (&rhs_func, Nfs, Nwaves, dim, grid, state, &ss, (void *)¶ms); - - delete [] Dmat; - - //base zone class data allocation: - r = new double[dim]; - - int len = dim*Nwaves*Ncomps*2; - - basis = new double[len]; - - for (int i=0; iiErsp_sys, &ind1, &ind2, &j2); -} - -/*******************************************************************/ - -void flre_zone::calc_final_fields (void) -{ -//makes spacing out of the grid with the solution; -//evaluates the whole system vector from the existing state vector stored in EB array; -//transforms the solution to the lab frame; - -//for spacing out: -int dimnew; -int *ind = new int[dim]; -double *rnew = new double[dim]; -double *snew = new double[dim*Nwaves*2]; -double *sold = new double[dim*Nwaves*2]; - -//here EB is in a mov frame -for (int k=0; knum_vars; -int num_eqs = me->num_eqs; - -double *rhs = new double[2*num_eqs]; - -for (int j=0; j<2*num_eqs; j++) rhs[j] = 0.0e0; - -//store spaced out values: -flre_zone *ptr = this; - -activate_fortran_modules_for_zone_ (&ptr); - -dim = dimnew; - -EB_mov = new double[dim*Ncomps*2]; //system vector in a mov frame - -for (int k=0; kbs->flag_back, &snew[2*Nwaves*k], &EB_mov[2*Ncomps*k], rhs, 1); -} - -deactivate_fortran_modules_for_zone_ (&ptr); - -//galilean transformation of the solution system vector EB_mov to lab frame: -for (int k=0; kbs->V_gal_sys, wd->omov, - r[k], &EB_mov[2*Ncomps*k], &EB[2*Ncomps*k]); -} - -if (DEBUG_FLAG) save_system_vector_in_mov_frame (); - -//clean up: -delete [] rnew; -delete [] snew; -delete [] sold; -delete [] ind; -delete [] rhs; -} - -/*****************************************************************************/ - -template inline void -calc_derive_of_func_product (int N, double *C, int n, const T1 *f, const T2 *g, T3 *fg) -{ -//N - max n index in C^k_n array -//C - binomial coefficients (C^k_n = C[n+k*(N+1)]) array -//n - order of the der, n<=N -//f - array of the f derivs -//g - array of the g derivs -//fg - the value of the fg deriv of n-th order - -*fg = 0; for (int k=0; k<=n; k++) *fg += C[n+k*(N+1)]*f[k]*g[n-k]; -} - -/*****************************************************************************/ - -inline void galilean_transform_of_flre_state_vector (const flre_zone *zone, double V, complex omega, double r, const double *E1, double *E2) -{ -int *dim_Ersp_state = (int *) zone->me->dim_Ersp_state; -int *iErsp_state = (int *) zone->me->iErsp_state; - -//max orders of the derivative for Er, Es, Ep: -int mo[3] = {dim_Ersp_state[0]-1, dim_Ersp_state[1]-1, dim_Ersp_state[2]-1}; - -//wave data: -int m = zone->cp->wd->m; -double kz = (zone->wd->n)/(zone->sd->bs->rtor); - -int ho = mo[2]; //max der order (2N-1); - -//binomial coefficients: -double *C = new double[(ho+1)*(ho+1)]; -binomial_coefficients (ho, C); - -double *htz = new double[2*(ho+1)]; -double *ht = htz, *hz = htz + ho + 1; - -eval_hthz (r, 0, ho, zone->bp, htz); //ht & hz derivs - -double *mor = new double[ho+1]; //(m/r) derivatives - -mor[0] = m/r; for (int o=1; o<=ho; o++) mor[o] = (-o/r)*mor[o-1]; - -double *ks = new double[ho+1]; -double *kp = new double[ho+1]; - -double htmor, hzmor; - -for (int o=0; o<=ho; o++) -{ - calc_derive_of_func_product (ho, C, o, ht, mor, &htmor); //ht*(m/r) derivatives - calc_derive_of_func_product (ho, C, o, hz, mor, &hzmor); //hz*(m/r) derivatives - - ks[o] = hzmor - ht[o]*kz; - kp[o] = htmor + hz[o]*kz; -} - -complex *E1c[3], *E2c[3]; //Er, Es, Ep derivative arrays in 2 frames - -for (int k=0; k<3; k++) -{ - E1c[k] = new complex[mo[k]+1]; - E2c[k] = new complex[mo[k]+1]; -} - -//getting complex fields from input double array in frame 1: -for (int k=0; k<3; k++) //over (rsp)-components -{ - for (int o=0; o<=mo[k]; o++) - { - int ind = 2*(iErsp_state[k] + o); - E1c[k][o] = E1[ind + 0] + I*E1[ind + 1]; - } -} - -complex *Br = new complex[ho+1]; -complex *Ez = new complex[ho+1]; -complex *htBr = new complex[ho+1]; -complex *hzBr = new complex[ho+1]; - -complex kpEs, ksEp, hzEp, htEs; - -//aux quants in frame 1: -for (int o=0; o<=ho; o++) -{ - calc_derive_of_func_product (ho, C, o, kp, E1c[1], &kpEs); - calc_derive_of_func_product (ho, C, o, ks, E1c[2], &ksEp); - - Br[o] = (c/omega)*(ksEp - kpEs); - - calc_derive_of_func_product (ho, C, o, ht, Br, &htBr[o]); - calc_derive_of_func_product (ho, C, o, hz, Br, &hzBr[o]); - - calc_derive_of_func_product (ho, C, o, ht, E1c[1], &htEs); - calc_derive_of_func_product (ho, C, o, hz, E1c[2], &hzEp); - - Ez[o] = hzEp - htEs; -} - -//Er, Es, Ep transformation: -for (int o=0; o<=mo[0]; o++) -{ - E2c[0][o] = E1c[0][o] - V/(omega)*(kz*E1c[0][o] + I*Ez[o+1]); -} - -for (int o=0; o<=mo[1]; o++) -{ - E2c[1][o] = E1c[1][o] + (V/c)*hzBr[o]; -} - -for (int o=0; o<=mo[2]; o++) -{ - E2c[2][o] = E1c[2][o] + (V/c)*htBr[o]; -} - -//Store new values to state vector: -for (int k=0; k<3; k++) //(r,s,p) -{ - for (int o=0; o<=mo[k]; o++) //der orders - { - int ind = 2*(iErsp_state[k] + o); - - E2[ind + 0] = real (E2c[k][o]); - E2[ind + 1] = imag (E2c[k][o]); - } -} - -for (int k=0; k<3; k++) -{ - delete [] E1c[k]; - delete [] E2c[k]; -} - -delete [] C; -delete [] htz; -delete [] mor; -delete [] ks; -delete [] kp; -delete [] Br; -delete [] Ez; -delete [] htBr; -delete [] hzBr; -} - -/*****************************************************************************/ - -inline void galilean_transform_of_flre_system_vector (const flre_zone *zone, double V, complex omega, double r, const double *EB1, double *EB2) -{ -int *dim_Ersp_sys = (int *) zone->me->dim_Ersp_sys; -int *iErsp_sys = (int *) zone->me->iErsp_sys; - -int *dim_Brsp_sys = (int *) zone->me->dim_Brsp_sys; -int *iBrsp_sys = (int *) zone->me->iBrsp_sys; - -//max orders of the derivative for Er, Es, Ep: -int moe[3] = {dim_Ersp_sys[0]-1, dim_Ersp_sys[1]-1, dim_Ersp_sys[2]-1}; -int mob[3] = {dim_Brsp_sys[0]-1, dim_Brsp_sys[1]-1, dim_Brsp_sys[2]-1}; - -//wave data: -int m = zone->cp->wd->m; -double kz = (zone->wd->n)/(zone->sd->bs->rtor); - -int ho = moe[2]; //max der order (2N); - -//binomial coefficients: -double *C = new double[(ho+1)*(ho+1)]; -binomial_coefficients (ho, C); - -double *htz = new double[2*(ho+1)]; -double *ht = htz, *hz = htz + ho + 1; - -eval_hthz (r, 0, ho, zone->bp, htz); //ht & hz derivs - -double *mor = new double[ho+1]; //(m/r) derivatives - -mor[0] = m/r; for (int o=1; o<=ho; o++) mor[o] = (-o/r)*mor[o-1]; - -double *ks = new double[ho+1]; -double *kp = new double[ho+1]; - -double htmor, hzmor; - -for (int o=0; o<=ho; o++) -{ - calc_derive_of_func_product (ho, C, o, ht, mor, &htmor); //ht*(m/r) derivatives - calc_derive_of_func_product (ho, C, o, hz, mor, &hzmor); //hz*(m/r) derivatives - - ks[o] = hzmor - ht[o]*kz; - kp[o] = htmor + hz[o]*kz; -} - -complex *E1c[3], *E2c[3]; //Er, Es, Ep derivative arrays in 2 frames -complex *B1c[3], *B2c[3]; //Br, Bs, Bp derivative arrays in 2 frames - -for (int k=0; k<3; k++) -{ - E1c[k] = new complex[moe[k]+1]; - E2c[k] = new complex[moe[k]+1]; - - B1c[k] = new complex[mob[k]+1]; - B2c[k] = new complex[mob[k]+1]; -} - -//getting complex fields from input double array in frame 1: -for (int k=0; k<3; k++) //over (rsp)-components -{ - for (int o=0; o<=moe[k]; o++) - { - int ind = 2*(iErsp_sys[k] + o); - E1c[k][o] = EB1[ind + 0] + I*EB1[ind + 1]; - } - - for (int o=0; o<=mob[k]; o++) - { - int ind = 2*(iBrsp_sys[k] + o); - B1c[k][o] = EB1[ind + 0] + I*EB1[ind + 1]; - } -} - -//aux quants in frame 1: -complex *Br = new complex[ho+1]; -complex *Ez = new complex[ho+1]; -complex *Et = new complex[ho+1]; -complex *htBr = new complex[ho+1]; -complex *hzBr = new complex[ho+1]; -complex *htEr = new complex[ho+1]; -complex *hzEr = new complex[ho+1]; - -complex kpEs, ksEp, hzEp, htEs, hzEs, htEp; - -for (int o=0; o<=ho; o++) -{ - calc_derive_of_func_product (ho, C, o, kp, E1c[1], &kpEs); - calc_derive_of_func_product (ho, C, o, ks, E1c[2], &ksEp); - - Br[o] = (c/omega)*(ksEp - kpEs); - - calc_derive_of_func_product (ho, C, o, ht, Br, &htBr[o]); - calc_derive_of_func_product (ho, C, o, hz, Br, &hzBr[o]); - - calc_derive_of_func_product (ho, C, o, ht, E1c[1], &htEs); - calc_derive_of_func_product (ho, C, o, hz, E1c[2], &hzEp); - - calc_derive_of_func_product (ho, C, o, ht, E1c[2], &htEp); - calc_derive_of_func_product (ho, C, o, hz, E1c[1], &hzEs); - - Et[o] = hzEs + htEp; - Ez[o] = hzEp - htEs; -} - -for (int o=0; o<=mob[2]; o++) -{ - calc_derive_of_func_product (ho, C, o, ht, E1c[0], &htEr[o]); - calc_derive_of_func_product (ho, C, o, hz, E1c[0], &hzEr[o]); -} - -//Er, Es, Ep transformation: -for (int o=0; o<=moe[0]; o++) -{ - E2c[0][o] = E1c[0][o] - V/(omega)*(kz*E1c[0][o] + I*Ez[o+1]); -} - -for (int o=0; o<=moe[1]; o++) -{ - E2c[1][o] = E1c[1][o] + (V/c)*hzBr[o]; -} - -for (int o=0; o<=moe[2]; o++) -{ - E2c[2][o] = E1c[2][o] + (V/c)*htBr[o]; -} - -//Br, Bs, Bp transformation: -for (int o=0; o<=mob[0]; o++) -{ - B2c[0][o] = B1c[0][o];// + (V/c)*Et[o]; -} - -for (int o=0; o<=mob[1]; o++) -{ - B2c[1][o] = B1c[1][o];// - (V/c)*hzEr[o]; -} - -for (int o=0; o<=mob[2]; o++) -{ - B2c[2][o] = B1c[2][o];// - (V/c)*htEr[o]; -} - -//Store new values to system vector: -for (int k=0; k<3; k++) //(r,s,p) -{ - for (int o=0; o<=moe[k]; o++) //der orders - { - int ind = 2*(iErsp_sys[k] + o); - - EB2[ind + 0] = real (E2c[k][o]); - EB2[ind + 1] = imag (E2c[k][o]); - } - - for (int o=0; o<=mob[k]; o++) //der orders - { - int ind = 2*(iBrsp_sys[k] + o); - - EB2[ind + 0] = real (B2c[k][o]); - EB2[ind + 1] = imag (B2c[k][o]); - } -} - -for (int k=0; k<3; k++) -{ - delete [] E1c[k]; - delete [] E2c[k]; - delete [] B1c[k]; - delete [] B2c[k]; -} - -delete [] C; -delete [] htz; -delete [] mor; -delete [] ks; -delete [] kp; -delete [] Br; -delete [] Ez; -delete [] Et; -delete [] htBr; -delete [] hzBr; -delete [] htEr; -delete [] hzEr; -} - -/*****************************************************************************/ - -inline void system_to_state_copy (const flre_zone *zone, double *system, double *state) -{ -for (int k=0; k<3; k++) -{ - for (int i=0; ime->dim_Ersp_state[k]; i++) - { - state[2*(zone->me->iErsp_state[k]+i)+0] = system[2*(zone->me->iErsp_sys[k]+i)+0]; - state[2*(zone->me->iErsp_state[k]+i)+1] = system[2*(zone->me->iErsp_sys[k]+i)+1]; - } -} -} - -/*****************************************************************************/ - -inline void state_to_system_copy (const flre_zone *zone, double *state, double *system) -{ -for (int k=0; k<3; k++) -{ - for (int i=0; ime->dim_Ersp_state[k]; i++) - { - system[2*(zone->me->iErsp_sys[k]+i)+0] = state[2*(zone->me->iErsp_state[k]+i)+0]; - system[2*(zone->me->iErsp_sys[k]+i)+1] = state[2*(zone->me->iErsp_state[k]+i)+1]; - } -} -} - -/*****************************************************************************/ - -void get_sys_ind_array_ (flre_zone **ptr, int *sys_ind) -{ -flre_zone *zone = (flre_zone *)(*ptr); - -for (int k=0; kNwaves; k++) -{ - sys_ind[k] = zone->me->sys_ind[k] + 1; //in Fortran index starts from 1 -} -} - -/*******************************************************************/ - -void activate_fortran_modules_for_zone_ (flre_zone **ptr) -{ -flre_zone *zone = (flre_zone *)(*ptr); - -setup_flre_data_module_ (&zone); - -calc_and_set_maxwell_system_parameters_module_ (); - -allocate_and_set_conductivity_arrays_ (); - -set_cond_profiles_in_mode_data_module_ (&(zone->cp)); - -set_sysmat_profiles_in_mode_data_module_ (&(zone->sp)); -} - -/*******************************************************************/ - -void deactivate_fortran_modules_for_zone_ (flre_zone **ptr) -{ -flre_zone *zone = (flre_zone *)(*ptr); - -deallocate_conductivity_arrays_ (); - -clean_maxwell_system_parameters_module_ (); - -clean_flre_data_module_ (); -} - -/*******************************************************************/ - -void flre_zone::save_system_vector_in_mov_frame (void) -{ -char *path2linear = new char[1024]; - -eval_path_to_linear_data (sd->path2project, wd->m, wd->n, wd->olab, path2linear); - -char *fname = new char[1024]; - -sprintf (fname, "%szone_%d_EB_mov.dat", path2linear, index); - -FILE *out; -if (!(out = fopen (fname, "w"))) -{ - fprintf (stderr, "\nFailed to open file %s\a\n", fname); -} - -for (int i=0; ime->num_eqs)]; - -for (int j=0; j<2*(zone->me->num_eqs); j++) rhs[j] = 0.0e0; - -double *state = new double[2*(zone->Nwaves)]; -double *sys_mov = new double[2*(zone->Ncomps)]; -double *sys_lab = new double[2*(zone->Ncomps)]; - -activate_fortran_modules_for_zone_ (ptr); - -for (int k=0; kNwaves; k++) //over basis system vectors: -{ - int ind = zone->ib(0, k, 0, 0); - - //calc full flre system vector in mov frame: - system_to_state_copy (zone, EB1 + ind, state); - - state2sys_ (r, zone->sd->bs->flag_back, state, sys_mov, rhs, 1); - - galilean_transform_of_flre_system_vector (zone, - zone->sd->bs->V_gal_sys, - zone->wd->omov, *r, sys_mov, sys_lab); - - transform_of_flre_system_vector_to_cyl_coordinates (zone, *r, sys_lab, EB2 + ind); -} - -deactivate_fortran_modules_for_zone_ (ptr); - -delete [] rhs; -delete [] state; -delete [] sys_mov; -delete [] sys_lab; -} - -/*****************************************************************************/ - -inline void transform_of_flre_system_vector_to_cyl_coordinates (const flre_zone *zone, double r, const double *EB1, double *EB2) -{ -int *dim_Ersp_sys = (int *) zone->me->dim_Ersp_sys; -int *iErsp_sys = (int *) zone->me->iErsp_sys; - -int *dim_Brsp_sys = (int *) zone->me->dim_Brsp_sys; -int *iBrsp_sys = (int *) zone->me->iBrsp_sys; - -//max orders of the derivative for Er, Es, Ep: -int moe[3] = {dim_Ersp_sys[0]-1, dim_Ersp_sys[1]-1, dim_Ersp_sys[2]-1}; -int mob[3] = {dim_Brsp_sys[0]-1, dim_Brsp_sys[1]-1, dim_Brsp_sys[2]-1}; - -int ho = moe[2]; //max der order (2N) of (s, p or theta, z) components; - -//binomial coefficients: -double *C = new double[(ho+1)*(ho+1)]; -binomial_coefficients (ho, C); - -double *htz = new double[2*(ho+1)]; -double *ht = htz, *hz = htz + ho + 1; - -eval_hthz (r, 0, ho, zone->bp, htz); //ht & hz derivs - -complex *E1c[3], *E2c[3]; //Er, Es, Ep and Er, Et, Ez derivative arrays -complex *B1c[3], *B2c[3]; //Br, Bs, Bp and Br, Br, Bz derivative arrays - -for (int k=0; k<3; k++) -{ - E1c[k] = new complex[moe[k]+1]; - E2c[k] = new complex[moe[k]+1]; - - B1c[k] = new complex[mob[k]+1]; - B2c[k] = new complex[mob[k]+1]; -} - -//getting complex fields from input double array in rsp: -for (int k=0; k<3; k++) //over (rsp)-components -{ - for (int o=0; o<=moe[k]; o++) - { - int ind = 2*(iErsp_sys[k] + o); - E1c[k][o] = EB1[ind + 0] + I*EB1[ind + 1]; - } - - for (int o=0; o<=mob[k]; o++) - { - int ind = 2*(iBrsp_sys[k] + o); - B1c[k][o] = EB1[ind + 0] + I*EB1[ind + 1]; - } -} - -//aux quants: -complex hzAp, htAs, hzAs, htAp; - -//electric field transformation: -for (int o=0; o<=moe[0]; o++) E2c[0][o] = E1c[0][o]; //r components are the same - -for (int o=0; o<=moe[1]; o++) //theta -{ - calc_derive_of_func_product (ho, C, o, hz, E1c[1], &hzAs); - calc_derive_of_func_product (ho, C, o, ht, E1c[2], &htAp); - - E2c[1][o] = hzAs + htAp; -} - -for (int o=0; o<=moe[2]; o++) //z -{ - calc_derive_of_func_product (ho, C, o, hz, E1c[2], &hzAp); - calc_derive_of_func_product (ho, C, o, ht, E1c[1], &htAs); - - E2c[2][o] = hzAp - htAs; -} - -//magnetic field transformation: -for (int o=0; o<=mob[0]; o++) B2c[0][o] = B1c[0][o]; //r components are the same - -for (int o=0; o<=mob[1]; o++) //theta -{ - calc_derive_of_func_product (ho, C, o, hz, B1c[1], &hzAs); - calc_derive_of_func_product (ho, C, o, ht, B1c[2], &htAp); - - B2c[1][o] = hzAs + htAp; -} - -for (int o=0; o<=mob[2]; o++) //z -{ - calc_derive_of_func_product (ho, C, o, hz, B1c[2], &hzAp); - calc_derive_of_func_product (ho, C, o, ht, B1c[1], &htAs); - - B2c[2][o] = hzAp - htAs; -} - -//Store new values to system vector: -for (int k=0; k<3; k++) //(r,s,p) -{ - for (int o=0; o<=moe[k]; o++) //der orders - { - int ind = 2*(iErsp_sys[k] + o); - - EB2[ind + 0] = real (E2c[k][o]); - EB2[ind + 1] = imag (E2c[k][o]); - } - - for (int o=0; o<=mob[k]; o++) //der orders - { - int ind = 2*(iBrsp_sys[k] + o); - - EB2[ind + 0] = real (B2c[k][o]); - EB2[ind + 1] = imag (B2c[k][o]); - } -} - -for (int k=0; k<3; k++) -{ - delete [] E1c[k]; - delete [] E2c[k]; - delete [] B1c[k]; - delete [] B2c[k]; -} - -delete [] C; -delete [] htz; -} - -/*****************************************************************************/ - -void get_iersp_sys_array_ (flre_zone **ptr, int *iErsp_sys) -{ -flre_zone *Z = (flre_zone *)(*ptr); - -for (uchar k=0; k<3; k++) iErsp_sys[k] = Z->me->iErsp_sys[k] + 1; -} - -/*****************************************************************************/ - -void get_ibrsp_sys_array_ (flre_zone **ptr, int *iBrsp_sys) -{ -flre_zone *Z = (flre_zone *)(*ptr); - -for (uchar k=0; k<3; k++) iBrsp_sys[k] = Z->me->iBrsp_sys[k] + 1; -} - -/*****************************************************************************/ - -void flre_zone::calc_all_quants (void) -{ -qp = new flre_quants (this); - -calculate_JaE (qp); - -qp->calculate_local_profiles (); - -qp->calculate_integrated_profiles (); - -transform_quants_to_lab_cyl_frame (qp); //transforms and saves -} - -/*****************************************************************************/ - -void flre_zone::save_all_quants (void) -{ -qp->save_profiles (); -} - -/*****************************************************************************/ - -void flre_zone::eval_diss_power_density (double x, int type, int spec, double * dpd) -{ -interp_diss_power_density (qp, x, type, spec, dpd); -} - -/*****************************************************************************/ - -void flre_zone::eval_current_density (double x, int type, int spec, int comp, double * J) -{ -interp_current_density (qp, x, type, spec, comp, J); -} - -/*****************************************************************************/ - -void flre_zone::calc_dispersion (void) -{ -dp = new disp_profiles (Nwaves, sp->dimx, sp->x, sd->bs->flag_back); - -dp->calculate_dispersion_profiles (); -} - -/*****************************************************************************/ - -void flre_zone::save_dispersion (void) -{ -char * path2disp = new char[512]; -eval_path_to_dispersion_data (sd->path2project, wd->m, wd->n, wd->olab, path2disp); - -char * filename = new char[1024]; -sprintf (filename, "%szone_%d_%s", path2disp, index, "kr.dat"); - -dp->save_dispersion_profiles (filename); - -delete [] path2disp; -delete [] filename; -} - -/*****************************************************************************/ diff --git a/KiLCA/flre/flre_zone.h b/KiLCA/flre/flre_zone.h deleted file mode 100644 index c9622474..00000000 --- a/KiLCA/flre/flre_zone.h +++ /dev/null @@ -1,224 +0,0 @@ -/*! \file flre_zone.h - \brief The declaration of flre_zone class. -*/ - -#ifndef FLRE_ZONE - -#define FLRE_ZONE - -#include "code_settings.h" - -#include "zone.h" -#include "hmedium_zone.h" -#include "maxwell_eqs_data.h" -#include "cond_profs.h" -#include "sysmat_profs.h" -#include "disp_profs.h" -#include "flre_quants.h" - -/*****************************************************************************/ - -/*! \class flre_zone - \brief The class represents properties and data of a plasma zone described by FLRE. -*/ -class flre_zone : public zone -{ -public: - maxwell_eqs_data *me; //!= 2N+1, where N - order of flr expansion - int max_dim_c; //! norm_fac - - int Nfs; //!iErsp_sys[comp]; - else return me->iBrsp_sys[comp-3]; - } - - inline int iF(int node, int comp, int part) - { - //indexing function for E, B fields in EB system array - return part + 2*(iF(comp) + Ncomps*(node)); - } - -public: - flre_zone (const settings *sd_p, const background *bp_p, const wave_data *wd_p, - char *path_p, int index_p) : zone (sd_p, bp_p, wd_p, path_p, index_p) - { - me = NULL; - cp = NULL; - sp = NULL; - dp = NULL; - qp = NULL; - - EB_mov = NULL; - } - - ~flre_zone (void) - { - if (me) delete me; - if (cp) delete cp; - if (sp) delete sp; - if (dp) delete dp; - if (qp) delete qp; - - delete [] EB_mov; - } - - void read_settings (char * file); - - void print_settings (void); - - void calc_basis_fields (int flag = 0); - - void copy_E_and_B_fields (double *); - - void calc_final_fields (void); - - void calc_dispersion (void); - - void save_dispersion (void); - - void calculate_field_profiles_orth (void); - - void save_system_vector_in_mov_frame (void); - - void calc_all_quants (void); - - void save_all_quants (void); - - void eval_diss_power_density (double x, int type, int spec, double * dpd); - - void eval_current_density (double x, int type, int spec, int comp, double * J); -}; - -/*****************************************************************************/ - -inline void galilean_transform_of_flre_state_vector (const flre_zone *zone, double V, complex omega, double r, const double *E1, double *E2); - -inline void galilean_transform_of_flre_system_vector (const flre_zone *zone, double V, complex omega, double r, const double *EB1, double *EB2); - -inline void system_to_state_copy (const flre_zone *zone, double *system, double *state); - -inline void state_to_system_copy (const flre_zone *zone, double *state, double *system); - -inline void transform_of_flre_system_vector_to_cyl_coordinates (const flre_zone *zone, double r, const double *EB1, double *EB2); - -/*****************************************************************************/ - -extern "C" -{ -void allocate_and_set_conductivity_arrays_ (void); - -void deallocate_conductivity_arrays_ (void); - -void set_cond_profiles_in_mode_data_module_ (cond_profiles **); - -void set_sysmat_profiles_in_mode_data_module_ (sysmat_profiles **); - -void set_conductivity_settings_c_ (flre_zone **ptr, int *flre_order, int *Nmax, int *gal_corr, int *rsp); - -void set_equations_settings_c_ (flre_zone **ptr, int *hom_sys, int *Nwaves, int *Nfs, int *Nphys, int *flag_debug); - -void set_collisions_settings_c_ (flre_zone **ptr, int *collmod); - -void setup_flre_data_module_ (flre_zone **); - -void clean_flre_data_module_ (); - -void calc_and_set_maxwell_system_parameters_module_ (void); - -void clean_maxwell_system_parameters_module_ (void); - -void center_equations_flre_ (int *Nw, int *len, flre_zone **code, double *EB, - int *neq, int *nvar, double *M, double *J); - -void infinity_equations_flre_ (int *Nw, int *len, flre_zone **code, double *EB, - int *neq, int *nvar, double *M, double *J); - -void ideal_wall_equations_flre_ (int *Nw, int *len, flre_zone **code, double *EB, - int *neq, int *nvar, double *M, double *J); - -void stitching_equations_flre_hommed_ (int *Nw1, int *len1, flre_zone **code1, double *EB1, - int *Nw2, int *len2, hmedium_zone **code2, double *EB2, - int *flg_ant, int *neq, int *nvar, double *M, double *J); - -void stitching_equations_flre_flre_ (int *Nw1, int *len1, flre_zone **code1, double *EB1, - int *Nw2, int *len2, flre_zone **code2, double *EB2, - int *flg_ant, int *neq, int *nvar, double *M, double *J); - -void calc_start_values_anywhere_low_derivs_ (double *, double *); - -void calc_start_values_center_with_correct_asymptotic_ (double *, double *); - -void calc_start_values_ideal_wall_low_derivs_ (double *, double *); - -void state2sys_ (double *, char *, double *, double *, double *, int len); - -void get_sys_ind_array_ (flre_zone **ptr, int *sys_ind); - -void activate_fortran_modules_for_zone_ (flre_zone **ptr); - -void deactivate_fortran_modules_for_zone_ (flre_zone **ptr); - -void calc_flre_basis_in_lab_cyl_frame_with_full_system_vectors_ (flre_zone **ptr, double *r, double *EB1, double *EB2); - -void get_iersp_sys_array_ (flre_zone **ptr, int *iErsp_sys); - -void get_ibrsp_sys_array_ (flre_zone **ptr, int *iBrsp_sys); - -void get_flre_order_ (int *flre_order); - -void get_gal_corr_ (int *gal_corr); - -void normalize_flre_basis_ (int * Ncomp, int * Nwaves, int * dim, double * basis, - int * iErsp_sys, int * ind1, int * ind2, int * node); -} - -/*****************************************************************************/ - -#endif diff --git a/KiLCA/flre/flre_zone_m.f90 b/KiLCA/flre/flre_zone_m.f90 new file mode 100644 index 00000000..d87f6c40 --- /dev/null +++ b/KiLCA/flre/flre_zone_m.f90 @@ -0,0 +1,1480 @@ +!> FLR (finite Larmor radius) plasma-response zone, formerly the C++ +!> flre_zone class (flre_zone.{h,cpp}). The most complex zone_t subtype: +!> orchestrates the (already-Fortran) per-zone Maxwell-equations/ +!> conductivity/sysmat/dispersion/quants sibling modules, drives the ODE +!> integration of the basis solutions (calculate_field_profiles_orth), and +!> re-spaces/transforms the final solution to the lab frame +!> (calc_final_fields). +!> +!> Field renamed from the C++ class: `dp` -> `dp_handle` (collides with the +!> `dp` real-kind parameter from `constants`). +!> +!> Several free C functions declared in flre_zone.h are callbacks invoked BY +!> pre-existing legacy Fortran (flre_sett_m.f90's setup_flre_data_module, +!> KiLCA/flre/maxwell_eqs/flre.f90, KiLCA/interface/wave_code_interface.cpp) +!> with a zone handle passed BY REFERENCE (address-of-handle, matching the +!> oracle's `flre_zone **ptr` convention) -- NOT by VALUE like the +!> mode.cpp-facing zone_*_c dispatch shims in kilca_zone_m. These are defined +!> here as bind(C) subroutines taking `integer(c_intptr_t), intent(in)` +!> (no VALUE attribute). +!> +!> path2linear/path2dispersion: the oracle recomputes these via +!> eval_path_to_linear_data/eval_path_to_dispersion_data (mode.cpp, still +!> C++, NOT extern "C" so unreachable from Fortran). mode.cpp already +!> computes the identical strings once at mode construction and copies them +!> into the shared `mode_data` Fortran module (mode_m.f90) via +!> copy_mode_paths_to_mode_data_module_; this module reads them from there +!> instead of recomputing, which is both simpler and guarantees identical +!> strings to whatever mode.cpp itself uses for the same mode. +module kilca_flre_zone_m + use, intrinsic :: iso_c_binding, only: c_int, c_intptr_t, c_double, c_char, & + c_ptr, c_funptr, c_funloc, c_loc, c_f_pointer, c_null_ptr, c_null_char + use constants, only: dp, im + use kilca_zone_m, only: zone_t, zone_register, handle_to_zone, zone_read, zone_print, & + skip_line, read_real_before_hash, read_int_before_hash, read_token_before_hash, & + read_complex_before_hash, & + BOUNDARY_CENTER, BOUNDARY_INFINITY, BOUNDARY_IDEALWALL, BOUNDARY_INTERFACE, BOUNDARY_ANTENNA + use kilca_maxwell_eqs_data_m, only: maxwell_eqs_data_create, maxwell_eqs_data_destroy, & + get_me_num_vars, get_me_num_eqs, get_me_der_order, & + get_me_dim_ersp_state, get_me_iersp_state, & + get_me_dim_ersp_sys, get_me_iersp_sys, & + get_me_dim_brsp_sys, get_me_ibrsp_sys, & + get_me_sys_ind, get_me_nwaves + use kilca_cond_profiles_m, only: cond_profiles_create, cond_profiles_destroy, & + get_cond_flag_back, get_cond_path2linear, get_cond_nc + use kilca_sysmat_profiles_m, only: sysmat_profiles_create, sysmat_profiles_destroy, & + get_sysmat_dimx, get_sysmat_x_ptr + use kilca_disp_profiles_m, only: disp_profiles_create, disp_profiles_destroy, & + disp_profiles_calculate, disp_profiles_save + use kilca_flre_quants_m, only: flre_quants_create, flre_quants_destroy, & + flre_quants_calculate_jae, flre_quants_calculate_local_profiles, & + flre_quants_calculate_integrated_profiles, flre_quants_transform_quants_to_lab_cyl_frame, & + flre_quants_save_profiles, flre_quants_interp_diss_power_density, & + flre_quants_interp_current_density + use kilca_background_data_m, only: get_background_x0, get_background_xlast, eval_hthz + use kilca_transforms_m, only: transform_EB_from_rsp_to_cyl + use kilca_solver_m, only: rhs_func + use kilca_interp_m, only: sparse_grid_polynom + use mode_data, only: md_path2linear => path2linear, md_path2dispersion => path2dispersion + implicit none + private + + !> Speed of light at full double precision, mirroring the C++ oracle's + !> constants.h that this ported code descends from. The Fortran constants + !> module keeps a legacy single-precision c for its own physics. + real(dp), parameter :: c = 29979245800.0_dp + + public :: flre_zone_t + public :: flre_zone_create_ + public :: set_equations_settings_c_, set_conductivity_settings_c_, set_collisions_settings_c_ + public :: get_iersp_sys_array_, get_ibrsp_sys_array_, get_sys_ind_array_ + public :: activate_fortran_modules_for_zone_, deactivate_fortran_modules_for_zone_ + public :: calc_flre_basis_in_lab_cyl_frame_with_full_system_vectors_ + public :: flre_zone_get_flre_order_, flre_zone_get_cp_ + + type, bind(C) :: solver_settings_local_t + integer(c_int) :: Nort + real(c_double) :: eps_rel + real(c_double) :: eps_abs + real(c_double) :: norm_fac + integer(c_int) :: debug + end type solver_settings_local_t + + !> Mirrors kilca_solver_m's private rhs_func_params_t field-for-field + !> (cannot `use` it directly: not in that module's public list). + type, bind(C) :: rhs_func_params_local_t + integer(c_int) :: Nwaves + integer(c_int) :: Nphys + integer(c_int) :: Nfs + type(c_ptr) :: Dmat + integer(c_intptr_t) :: sp + end type rhs_func_params_local_t + + type, extends(zone_t) :: flre_zone_t + integer(c_intptr_t) :: me = 0, cp = 0, sp = 0, dp_handle = 0, qp = 0 + integer(c_intptr_t) :: self_handle = 0 + integer :: flre_order = 0, Nmax = 0, gal_corr = 0, N = 0, max_dim_c = 0 + real(dp) :: D = 0, eps_out = 0, eps_res = 0 + real(dp) :: dr_out = 0, dr_res = 0, del = 0 + integer :: hom_sys = 0 + integer :: Nort = 0 + real(dp) :: norm_fac = 0 + integer :: Nfs = 0 + complex(dp), allocatable :: EB_mov(:, :) + integer :: collmod(2) = 0 + integer :: rsp = 0 + contains + procedure :: read_settings => flre_read_settings + procedure :: print_settings => flre_print_settings + procedure :: calc_basis_fields => flre_calc_basis_fields + procedure :: copy_E_and_B_fields => flre_copy_E_and_B_fields + procedure :: calc_final_fields => flre_calc_final_fields + procedure :: calc_dispersion => flre_calc_dispersion + procedure :: save_dispersion => flre_save_dispersion + procedure :: calc_all_quants => flre_calc_all_quants + procedure :: save_all_quants => flre_save_all_quants + procedure :: eval_diss_power_density => flre_eval_diss_power_density + procedure :: eval_current_density => flre_eval_current_density + final :: flre_zone_finalize + end type flre_zone_t + + interface calc_deriv_product + module procedure calc_deriv_product_rr + module procedure calc_deriv_product_rc + end interface calc_deriv_product + + !> Free-function / legacy-Fortran callbacks. Names without a trailing + !> underscore are pre-existing plain Fortran subprograms (90k-LOC legacy + !> physics code, predating this port); gfortran's default external-name + !> mangling already matches the trailing-underscore C declarations in + !> flre_zone.h, so they are called here by their bare Fortran name. + !> Array dummies use assumed-size (F77 sequence association) to match + !> the legacy routines' own explicit-shape, descriptor-free ABI. + interface + subroutine setup_flre_data_module(zone) + import :: c_intptr_t + integer(c_intptr_t), intent(in) :: zone + end subroutine setup_flre_data_module + + subroutine clean_flre_data_module() + end subroutine clean_flre_data_module + + subroutine calc_and_set_maxwell_system_parameters_module() + end subroutine calc_and_set_maxwell_system_parameters_module + + subroutine clean_maxwell_system_parameters_module() + end subroutine clean_maxwell_system_parameters_module + + subroutine allocate_and_set_conductivity_arrays() + end subroutine allocate_and_set_conductivity_arrays + + subroutine deallocate_conductivity_arrays() + end subroutine deallocate_conductivity_arrays + + subroutine set_cond_profiles_in_mode_data_module(cp) + import :: c_intptr_t + integer(c_intptr_t), intent(in) :: cp + end subroutine set_cond_profiles_in_mode_data_module + + subroutine set_sysmat_profiles_in_mode_data_module(sp) + import :: c_intptr_t + integer(c_intptr_t), intent(in) :: sp + end subroutine set_sysmat_profiles_in_mode_data_module + + subroutine calc_start_values_center_with_correct_asymptotic(rstart, zstart) + import :: dp + real(dp), intent(in) :: rstart + complex(dp), intent(out) :: zstart(*) + end subroutine calc_start_values_center_with_correct_asymptotic + + subroutine calc_start_values_anywhere_low_derivs(rstart, zstart) + import :: dp + real(dp), intent(in) :: rstart + complex(dp), intent(out) :: zstart(*) + end subroutine calc_start_values_anywhere_low_derivs + + subroutine state2sys(rpt, flagback, v_state, v_sys, rhs) + import :: dp + real(dp), intent(in) :: rpt + character(len=*), intent(in) :: flagback + complex(dp), intent(in) :: v_state(*) + complex(dp), intent(out) :: v_sys(*) + complex(dp), intent(in) :: rhs(*) + end subroutine state2sys + + subroutine normalize_flre_basis(D, Nw, dim, basis, iErsp_sys, ind1, ind2, node) + import :: dp + integer, intent(in) :: D, Nw, dim, ind1, ind2, node + complex(dp), intent(inout) :: basis(*) + integer, intent(in) :: iErsp_sys(3) + end subroutine normalize_flre_basis + + function get_background_rtor() bind(C, name="get_background_rtor_") result(rtor) + import :: c_double + real(c_double) :: rtor + end function get_background_rtor + + function get_background_V_gal_sys() bind(C, name="get_background_V_gal_sys_") result(vgal) + import :: c_double + real(c_double) :: vgal + end function get_background_V_gal_sys + + function get_background_flag_back() bind(C, name="get_background_flag_back_") result(ch) + import :: c_char + character(kind=c_char) :: ch + end function get_background_flag_back + + integer(c_int) function get_output_flag_dispersion() & + bind(C, name="get_output_flag_dispersion_") + import :: c_int + end function get_output_flag_dispersion + + !> Still-C++ shared.cpp free function (binomial_coefficients_, + !> extern "C"); same interface duplicated per-module already by + !> kilca_cond_profiles_m/kilca_flre_quants_m, since it is module- + !> private there too. + subroutine binomial_coefficients_local(N, BC) bind(C, name="binomial_coefficients_") + import :: c_int, c_double + integer(c_int), value :: N + real(c_double), intent(out) :: BC(*) + end subroutine binomial_coefficients_local + + !> Local redeclaration of kilca_solver_m's integrate_basis_vecs with + !> a COMPLEX Smat dummy (bind(C) explicit-shape array dummies are + !> passed as plain base addresses, so this is ABI-identical to the + !> module's own REAL(c_double) declaration -- same established + !> convention as LAPACK/legacy-Fortran complex-as-flat-real calls + !> elsewhere in this port). + function integrate_basis_vecs_local(f, Nfs, Nw, dim, rvec, Smat, ss_ptr, params) & + result(ret) bind(C, name="integrate_basis_vecs") + import :: c_funptr, c_int, c_double, c_ptr, dp + type(c_funptr), value :: f + integer(c_int), value :: Nfs, Nw, dim + real(c_double), intent(in) :: rvec(0:dim - 1) + complex(dp), intent(inout) :: Smat(0:Nfs*Nw*dim - 1) + type(c_ptr), value :: ss_ptr, params + integer(c_int) :: ret + end function integrate_basis_vecs_local + end interface + +contains + + !> ---- construction / destruction ---- + + function flre_zone_create_(sd_ptr, bp_ptr, wd_handle, path, index_p) & + result(handle) bind(C, name="flre_zone_create_") + integer(c_intptr_t), value :: sd_ptr, bp_ptr, wd_handle + character(kind=c_char), intent(in) :: path(*) + integer(c_int), value :: index_p + integer(c_intptr_t) :: handle + + type(flre_zone_t), pointer :: fz + class(zone_t), pointer :: zp + type(c_ptr) :: wd_cptr + integer :: i + + allocate (fz) + fz%bp = bp_ptr + fz%index = int(index_p) + fz%path = '' + i = 0 + do + if (path(i + 1) == c_null_char .or. i >= len(fz%path)) exit + fz%path(i + 1:i + 1) = path(i + 1) + i = i + 1 + end do + wd_cptr = transfer(wd_handle, wd_cptr) + call c_f_pointer(wd_cptr, fz%wd) + + fz%me = 0 + fz%cp = 0 + fz%sp = 0 + fz%dp_handle = 0 + fz%qp = 0 + + zp => fz + handle = zone_register(zp) + fz%self_handle = handle + end function flre_zone_create_ + + subroutine flre_zone_finalize(self) + type(flre_zone_t), intent(inout) :: self + if (self%me /= 0) call maxwell_eqs_data_destroy(self%me) + if (self%cp /= 0) call cond_profiles_destroy(self%cp) + if (self%sp /= 0) call sysmat_profiles_destroy(self%sp) + if (self%dp_handle /= 0) call disp_profiles_destroy(self%dp_handle) + if (self%qp /= 0) call flre_quants_destroy(self%qp) + end subroutine flre_zone_finalize + + !> ---- settings ---- + + subroutine flre_read_settings(self, file) + class(flre_zone_t), intent(inout) :: self + character(len=*), intent(in) :: file + integer :: unit, ios, k + + call zone_read(self, file) + + open (newunit=unit, file=trim(file), status='old', action='read', iostat=ios) + if (ios /= 0) then + write (*, '(a,a)') 'error: flre_zone: read_settings: failed to open file ', trim(file) + stop 1 + end if + + do k = 1, 8 + call skip_line(unit) + end do + + call skip_line(unit) + call read_int_before_hash(unit, self%flre_order) + call read_int_before_hash(unit, self%Nmax) + call read_int_before_hash(unit, self%gal_corr) + call read_int_before_hash(unit, self%N) + call read_int_before_hash(unit, self%max_dim_c) + call read_real_before_hash(unit, self%D) + call read_real_before_hash(unit, self%eps_out) + call read_real_before_hash(unit, self%eps_res) + call read_int_before_hash(unit, self%hom_sys) + call skip_line(unit) + + call skip_line(unit) + call read_int_before_hash(unit, self%max_dim) + call read_real_before_hash(unit, self%eps_rel) + call read_real_before_hash(unit, self%eps_abs) + call read_int_before_hash(unit, self%Nort) + call read_real_before_hash(unit, self%norm_fac) + call read_real_before_hash(unit, self%dr_out) + call read_real_before_hash(unit, self%dr_res) + call read_real_before_hash(unit, self%del) + call skip_line(unit) + + call skip_line(unit) + call read_int_before_hash(unit, self%deg) + call read_real_before_hash(unit, self%reps) + call read_real_before_hash(unit, self%aeps) + call read_real_before_hash(unit, self%step) + call skip_line(unit) + + call skip_line(unit) + call read_int_before_hash(unit, self%flag_debug) + call skip_line(unit) + + call skip_line(unit) + call read_int_before_hash(unit, self%collmod(1)) + call read_int_before_hash(unit, self%collmod(2)) + call skip_line(unit) + + close (unit) + + if (self%hom_sys /= 0) then + write (*, '(a)') 'warning: homogenious limit should not be normally used.' + stop 1 + end if + + self%Nwaves = 6*self%flre_order - 2 + self%Ncomps = 6*self%flre_order + 7 + + if (self%bc1 == BOUNDARY_CENTER .or. self%bc1 == BOUNDARY_IDEALWALL .or. & + self%bc2 == BOUNDARY_INFINITY .or. self%bc2 == BOUNDARY_IDEALWALL) then + self%Nfs = self%Nwaves/2 + else + self%Nfs = self%Nwaves + end if + + if (self%flag_debug /= 0) call self%print_settings() + end subroutine flre_read_settings + + subroutine flre_print_settings(self) + class(flre_zone_t), intent(in) :: self + call zone_print(self) + write (*, '(a)') '' + write (*, '(a)') 'Check for flre specific settings below:' + write (*, '(a,i0)') 'order of FLR expansion: ', self%flre_order + write (*, '(a,i0)') 'highest cyclotron harmonic: ', self%Nmax + write (*, '(a,i0)') 'flag if to use correction term in conductivity: ', self%gal_corr + write (*, '(a,i0)') 'splines degree: ', self%N + write (*, '(a,i0)') & + 'maximum dimension of the grid for conductivity martices: ', self%max_dim_c + write (*, '(a,es16.8e3)') 'resonant layer width: ', self%D + write (*, '(a,es16.8e3)') & + 'error parameter for adaptive radial grid outside the resonant layer: ', self%eps_out + write (*, '(a,es16.8e3)') & + 'error parameter for the adaptive radial grid in the resonant layer: ', self%eps_res + write (*, '(a,i0)') 'flag for homogenious system: ', self%hom_sys + write (*, '(a,i0)') & + 'max number of orthonormalization steps (ONS) for the solver: ', self%Nort + write (*, '(a,es16.8e3)') 'controlling factor for ONS by QR: ', self%norm_fac + write (*, '(a,es16.8e3)') & + 'output grid step outside the resonance region for the ME solutions: ', self%dr_out + write (*, '(a,es16.8e3)') & + 'output grid step inside the resonance region for the ME solutions: ', self%dr_res + write (*, '(a,es16.8e3)') 'width of the resonance region: ', self%del + write (*, '(a,i0,1x,i0)') 'collisions model flags: ', self%collmod(1), self%collmod(2) + end subroutine flre_print_settings + + !> ---- basis-field calculation ---- + + subroutine flre_calc_basis_fields(self, flag) + class(flre_zone_t), intent(inout) :: self + integer, intent(in) :: flag + real(dp) :: a_, b_ + character(kind=c_char), target :: path2linear_buf(1025) + character(kind=c_char), target :: flag_back_buf(2) + character(kind=c_char), target :: path2linear_buf2(1025) + + if (flag /= 0) then + self%rsp = 0 + else + self%rsp = 1 + end if + + call setup_flre_data_module(self%self_handle) + + call calc_and_set_maxwell_system_parameters_module() + + self%me = maxwell_eqs_data_create(self%Nwaves) + + if (self%flag_debug /= 0) call print_maxwell_eqs_data_local(self%me) + + call allocate_and_set_conductivity_arrays() + + a_ = max(self%r1 - 1.0_dp, get_background_x0()) + b_ = min(self%r2 + 1.0_dp, get_background_xlast()) + + call to_cstr(trim(md_path2linear), path2linear_buf) + + self%cp = cond_profiles_create(c_loc(path2linear_buf), self%flre_order, self%gal_corr, & + self%N, self%max_dim_c, self%r1, self%r2, self%D, & + self%eps_out, self%eps_res, a_, b_, self%wd%r_res, & + real(self%wd%omov, dp), aimag(self%wd%omov), & + self%flag_debug, flag) + + call set_cond_profiles_in_mode_data_module(self%cp) + + if (flag /= 0) then + call deallocate_conductivity_arrays() + call clean_maxwell_system_parameters_module() + call clean_flre_data_module() + return + end if + + flag_back_buf(1) = get_cond_flag_back(self%cp) + flag_back_buf(2) = c_null_char + call get_cond_path2linear(self%cp, path2linear_buf2) + + self%sp = sysmat_profiles_create(self%Nwaves, c_loc(flag_back_buf), & + c_loc(path2linear_buf2), get_cond_nc(self%cp), & + self%max_dim_c, self%eps_out, self%flag_debug, & + self%r1, self%r2, self%wd%r_res) + + call set_sysmat_profiles_in_mode_data_module(self%sp) + + if (get_output_flag_dispersion() > 1) then + call self%calc_dispersion() + call self%save_dispersion() + end if + + call flre_calculate_field_profiles_orth(self) + + call deallocate_conductivity_arrays() + call clean_maxwell_system_parameters_module() + call clean_flre_data_module() + end subroutine flre_calc_basis_fields + + !> Translates flre_zone::calculate_field_profiles_orth. Boundary- + !> condition-dependent start values + integration direction, an + !> adaptive grid thickened near wd%r_res via dr_out/dr_res/del, ODE + !> integration of the fundamental solutions, and basis normalization. + !> Error branches (BOUNDARY_INFINITY "not implemented", unknown BCs) + !> stop exactly where the oracle exit(1)s, matching the oracle's own + !> commented-out alternative start-value calls (left as comments, never + !> activated). + subroutine flre_calculate_field_profiles_orth(self) + class(flre_zone_t), intent(inout) :: self + complex(dp), allocatable :: y(:, :) + integer :: ind1, ind2 + real(dp) :: ri, rf + integer :: Neq + real(dp), allocatable, target :: grid(:) + real(dp) :: sgn, r_res, rcur, dr + integer :: node, dim_local + complex(dp), allocatable, target :: state(:, :, :) + integer :: j, j1, j2, dj, k, ind, node_param + real(dp), allocatable, target :: Dmat(:) + type(solver_settings_local_t), target :: ss + type(rhs_func_params_local_t), target :: params + integer(c_int) :: ret + integer :: iErsp_sys_local(0:2) + + allocate (y(self%Nwaves, self%Nwaves)) + y = (0.0_dp, 0.0_dp) + + if (self%bc1 == BOUNDARY_CENTER) then + ri = self%r1 + rf = self%r2 + !calc_start_values_anywhere_low_derivs_ (&ri, y); -- oracle also has this commented out + call calc_start_values_center_with_correct_asymptotic(ri, y(:, 1:self%Nwaves/2)) + self%Nfs = self%Nwaves/2 + ind1 = 0 + ind2 = self%Nfs - 1 + else if (self%bc1 == BOUNDARY_IDEALWALL) then + ri = self%r1 + rf = self%r2 + call calc_start_values_anywhere_low_derivs(ri, y(:, 1:self%Nwaves/2)) + self%Nfs = self%Nwaves/2 + ind1 = 0 + ind2 = self%Nfs - 1 + else if (self%bc2 == BOUNDARY_INFINITY) then + ri = self%r2 + rf = self%r1 + self%Nfs = self%Nwaves/2 + ind1 = self%Nfs + ind2 = self%Nwaves - 1 + write (*, '(a)') 'flre_zone::calculate_field_profiles_orth: not implemented!' + stop 1 + else if (self%bc2 == BOUNDARY_IDEALWALL) then + ri = self%r2 + rf = self%r1 + call calc_start_values_anywhere_low_derivs(ri, y(:, 1:self%Nwaves/2)) + self%Nfs = self%Nwaves/2 + ind1 = 0 + ind2 = self%Nfs - 1 + else + ri = self%r1 + rf = self%r2 + self%Nfs = self%Nwaves + ind1 = 0 + ind2 = self%Nwaves - 1 + write (*, '(a)') 'flre_zone::calculate_field_profiles_orth: unknown BCs!' + stop 1 + end if + + Neq = 2*self%Nwaves*self%Nfs + + sgn = real(signum_local(rf - ri), dp) + + if (self%r1 <= self%wd%r_res .and. self%r2 >= self%wd%r_res) then + r_res = self%wd%r_res + + rcur = ri + node = 0 + do while ((rcur - rf)*sgn < 0.0_dp) + rcur = rcur + ((self%dr_out - self%dr_res)* & + (1.0_dp - exp(-(rcur - r_res)*(rcur - r_res)/self%del/self%del)) + & + self%dr_res)*sgn + node = node + 1 + end do + + dim_local = node + 1 + allocate (grid(dim_local)) + + rcur = ri + node = 0 + do while ((rcur - rf)*sgn < 0.0_dp) + node = node + 1 + grid(node) = rcur + rcur = rcur + ((self%dr_out - self%dr_res)* & + (1.0_dp - exp(-(rcur - r_res)*(rcur - r_res)/self%del/self%del)) + & + self%dr_res)*sgn + end do + grid(node + 1) = rf + else + dim_local = int(abs(rf - ri)/self%dr_out) + allocate (grid(dim_local)) + dr = (rf - ri)/real(dim_local - 1, dp) + do node = 0, dim_local - 1 + grid(node + 1) = ri + dr*node + end do + grid(dim_local) = rf + end if + + allocate (state(self%Nwaves, self%Nfs, dim_local)) + state = (0.0_dp, 0.0_dp) + + do j = 1, self%Nfs + call galilean_transform_of_flre_state_vector(self, get_background_V_gal_sys(), & + self%wd%olab, ri, y(:, j), & + state(:, j, 1)) + end do + + allocate (Dmat(2*self%Nwaves*(self%Nwaves + 2*self%Nfs))) + Dmat = 0.0_dp + + params%Nwaves = self%Nwaves + params%Nphys = self%Nwaves + params%Nfs = self%Nfs + params%Dmat = c_loc(Dmat) + params%sp = self%sp + + ss%Nort = self%Nort + ss%eps_rel = self%eps_rel + ss%eps_abs = self%eps_abs + ss%norm_fac = self%norm_fac + ss%debug = self%flag_debug + + ret = integrate_basis_vecs_local(c_funloc(rhs_func), self%Nfs, self%Nwaves, dim_local, & + grid, state, c_loc(ss), c_loc(params)) + + deallocate (Dmat) + + self%dim = dim_local + if (allocated(self%r)) deallocate (self%r) + allocate (self%r(self%dim)) + if (allocated(self%basis)) deallocate (self%basis) + allocate (self%basis(self%Ncomps, self%Nwaves, self%dim)) + self%basis = (0.0_dp, 0.0_dp) + + if (grid(1) == self%r1 .and. grid(dim_local) == self%r2) then + j1 = 1 + j2 = dim_local + dj = 1 + else if (grid(1) == self%r2 .and. grid(dim_local) == self%r1) then + j1 = dim_local + j2 = 1 + dj = -1 + else + write (*, '(a)') 'flre_zone::calculate_field_profiles_orth: error!' + stop 1 + end if + node_param = merge(dim_local - 1, 0, dj == 1) + + k = 0 + j = j1 + do while ((j - j2)*dj <= 0) + k = k + 1 + self%r(k) = grid(j) + do ind = ind1, ind2 + call state_to_system_copy(self, state(:, ind - ind1 + 1, j), & + self%basis(:, ind + 1, k)) + end do + j = j + dj + end do + + deallocate (grid, state, y) + + iErsp_sys_local(0) = get_me_iersp_sys(self%me, 0) + iErsp_sys_local(1) = get_me_iersp_sys(self%me, 1) + iErsp_sys_local(2) = get_me_iersp_sys(self%me, 2) + call normalize_flre_basis(self%Ncomps, self%Nwaves, self%dim, self%basis, & + iErsp_sys_local, ind1, ind2, node_param) + end subroutine flre_calculate_field_profiles_orth + + subroutine flre_copy_E_and_B_fields(self, EB_out) + class(flre_zone_t), intent(in) :: self + real(dp), intent(out) :: EB_out(*) + complex(dp) :: EBrsp(6), EBcyl(6) + integer :: node, comp, idx + + do node = 0, self%dim - 1 + do comp = 0, 5 + idx = iF_comp(self, comp) + EBrsp(comp + 1) = self%EB(idx + 1, node + 1) + end do + call transform_EB_from_rsp_to_cyl(self%bp, self%r(node + 1), EBrsp, EBcyl) + do comp = 0, 5 + EB_out(2*(comp + 6*node) + 1) = real(EBcyl(comp + 1), dp) + EB_out(2*(comp + 6*node) + 2) = aimag(EBcyl(comp + 1)) + end do + end do + end subroutine flre_copy_E_and_B_fields + + !> Translates flre_zone::calc_final_fields: thins the grid via + !> sparse_grid_polynom, evaluates full system vectors from the state + !> vectors via the legacy state2sys, then Galilean-transforms back to + !> the lab frame. self%r/self%EB are NOT reallocated (matching the + !> oracle, which overwrites the existing buffers in place and only + !> shrinks the logical `dim`); only self%EB_mov is freshly allocated at + !> the new (smaller-or-equal) dimension. + subroutine flre_calc_final_fields(self) + class(flre_zone_t), intent(inout) :: self + integer, allocatable :: ind(:) + real(dp), allocatable :: rnew(:) + real(dp), allocatable :: snew(:, :), sold(:, :) + complex(dp) :: state_tmp(self%Nwaves) + integer :: dimnew, num_vars, num_eqs, k, i, dim_old + complex(dp), allocatable :: rhs(:), v_sys(:) + character(kind=c_char) :: flag_back + real(dp) :: aeps_local, reps_local + + dim_old = self%dim + + allocate (ind(dim_old), rnew(dim_old)) + allocate (sold(2*self%Nwaves, dim_old), snew(2*self%Nwaves, dim_old)) + + do k = 1, dim_old + call system_to_state_copy(self, self%EB(:, k), state_tmp) + do i = 1, self%Nwaves + sold(2*i - 1, k) = real(state_tmp(i), dp) + sold(2*i, k) = aimag(state_tmp(i)) + end do + end do + + aeps_local = self%aeps + reps_local = self%reps + call sparse_grid_polynom(self%r, dim_old, sold, 2*self%Nwaves, self%deg, & + aeps_local, reps_local, self%step, dimnew, rnew, snew, ind) + + num_vars = get_me_num_vars(self%me) + num_eqs = get_me_num_eqs(self%me) + + allocate (rhs(num_eqs)) + rhs = (0.0_dp, 0.0_dp) + + call flre_activate_fortran_modules(self) + + self%dim = dimnew + if (allocated(self%EB_mov)) deallocate (self%EB_mov) + allocate (self%EB_mov(self%Ncomps, self%dim)) + + flag_back = get_background_flag_back() + + allocate (v_sys(num_vars)) + do k = 1, self%dim + self%r(k) = rnew(k) + do i = 1, self%Nwaves + state_tmp(i) = cmplx(snew(2*i - 1, k), snew(2*i, k), dp) + end do + call state2sys(self%r(k), flag_back, state_tmp, v_sys, rhs) + self%EB_mov(1:self%Ncomps, k) = v_sys(1:self%Ncomps) + end do + + call flre_deactivate_fortran_modules(self) + + do k = 1, self%dim + call galilean_transform_of_flre_system_vector(self, -get_background_V_gal_sys(), & + self%wd%omov, self%r(k), & + self%EB_mov(:, k), self%EB(:, k)) + end do + + !> if (DEBUG_FLAG) save_system_vector_in_mov_frame(); -- DEBUG_FLAG + !> is hard-coded 0 in code_settings.h (matching the established + !> flre_quants_m.f90 precedent for this exact macro), so this call + !> is dead code in the oracle and is not invoked here either. + + deallocate (ind, rnew, sold, snew, rhs, v_sys) + end subroutine flre_calc_final_fields + + !> Dead in the oracle (DEBUG_FLAG hard-coded 0 in code_settings.h), kept + !> as a translated-but-uncalled private procedure for completeness, per + !> the task's translation list. + subroutine flre_save_system_vector_in_mov_frame(self) + class(flre_zone_t), intent(in) :: self + character(len=1024) :: fname + integer :: unit, i, comp + + write (fname, '(a,a,i0,a)') trim(md_path2linear), 'zone_', self%index, '_EB_mov.dat' + open (newunit=unit, file=trim(fname), status='replace', action='write') + do i = 1, self%dim + write (unit, '(es24.16e3)', advance='no') self%r(i) + do comp = 1, self%Ncomps + write (unit, '(a,es24.16e3,a,es24.16e3)', advance='no') & + char(9), real(self%EB_mov(comp, i), dp), char(9), aimag(self%EB_mov(comp, i)) + end do + write (unit, *) + end do + close (unit) + end subroutine flre_save_system_vector_in_mov_frame + + subroutine flre_calc_dispersion(self) + class(flre_zone_t), intent(inout) :: self + character(kind=c_char), target :: flag_back_buf(2) + flag_back_buf(1) = get_background_flag_back() + flag_back_buf(2) = c_null_char + self%dp_handle = disp_profiles_create(self%Nwaves, get_sysmat_dimx(self%sp), & + get_sysmat_x_ptr(self%sp), c_loc(flag_back_buf)) + call disp_profiles_calculate(self%dp_handle) + end subroutine flre_calc_dispersion + + subroutine flre_save_dispersion(self) + class(flre_zone_t), intent(inout) :: self + character(kind=c_char), target :: filename(1025) + character(len=1024) :: fname_str + + write (fname_str, '(a,a,i0,a)') trim(md_path2dispersion), 'zone_', self%index, '_kr.dat' + call to_cstr(trim(fname_str), filename) + call disp_profiles_save(self%dp_handle, c_loc(filename)) + end subroutine flre_save_dispersion + + subroutine flre_calc_all_quants(self) + class(flre_zone_t), intent(inout) :: self + class(zone_t), pointer :: zp + type(c_ptr) :: x_cptr, ebmov_cptr + character(kind=c_char), target :: path2linear_buf(1025) + + call handle_to_zone(self%self_handle, zp) + select type (zp) + type is (flre_zone_t) + x_cptr = c_loc(zp%r) + ebmov_cptr = c_loc(zp%EB_mov) + end select + + call to_cstr(trim(md_path2linear), path2linear_buf) + + self%qp = flre_quants_create(self%cp, self%me, c_null_ptr, c_loc(path2linear_buf), & + self%flre_order, self%dim, x_cptr, self%Ncomps, ebmov_cptr, & + real(self%wd%omov, dp), aimag(self%wd%omov), & + self%bc1, self%bc2, self%index) + + call flre_quants_calculate_jae(self%qp) + call flre_quants_calculate_local_profiles(self%qp) + call flre_quants_calculate_integrated_profiles(self%qp) + call flre_quants_transform_quants_to_lab_cyl_frame(self%qp) + end subroutine flre_calc_all_quants + + subroutine flre_save_all_quants(self) + class(flre_zone_t), intent(inout) :: self + call flre_quants_save_profiles(self%qp) + end subroutine flre_save_all_quants + + subroutine flre_eval_diss_power_density(self, x, ttype, spec, dpd) + class(flre_zone_t), intent(in) :: self + real(dp), intent(in) :: x + integer, intent(in) :: ttype, spec + real(dp), intent(out) :: dpd(*) + call flre_quants_interp_diss_power_density(self%qp, x, ttype, spec, dpd) + end subroutine flre_eval_diss_power_density + + subroutine flre_eval_current_density(self, x, ttype, spec, comp, J) + class(flre_zone_t), intent(in) :: self + real(dp), intent(in) :: x + integer, intent(in) :: ttype, spec, comp + real(dp), intent(out) :: J(*) + call flre_quants_interp_current_density(self%qp, x, ttype, spec, comp, J) + end subroutine flre_eval_current_density + + !> ---- activation helpers (shared by calc_final_fields and the + !> bind(C) activate_/deactivate_fortran_modules_for_zone_ entry points + !> called from wave_code_interface.cpp) ---- + + subroutine flre_activate_fortran_modules(self) + class(flre_zone_t), intent(inout) :: self + call setup_flre_data_module(self%self_handle) + call calc_and_set_maxwell_system_parameters_module() + call allocate_and_set_conductivity_arrays() + call set_cond_profiles_in_mode_data_module(self%cp) + call set_sysmat_profiles_in_mode_data_module(self%sp) + end subroutine flre_activate_fortran_modules + + subroutine flre_deactivate_fortran_modules(self) + class(flre_zone_t), intent(inout) :: self + call deallocate_conductivity_arrays() + call clean_maxwell_system_parameters_module() + call clean_flre_data_module() + end subroutine flre_deactivate_fortran_modules + + !> ---- inline-helper translations (system_to_state_copy etc) ---- + + !> Indexing function for Er,Es,Ep,Br,Bs,Bp (comp=0:5) -> the physical + !> system-vector component index (0-based) that get_me_iersp_sys_/ + !> get_me_ibrsp_sys_ map it to. NOT an array-layout helper (basis/EB are + !> native Fortran arrays, indexed directly elsewhere): this is purely + !> the maxwell_eqs_data component lookup the oracle's flre_zone::iF(int) + !> performed. + integer function iF_comp(self, comp) result(idx) + class(flre_zone_t), intent(in) :: self + integer, intent(in) :: comp + if (comp < 3) then + idx = get_me_iersp_sys(self%me, comp) + else + idx = get_me_ibrsp_sys(self%me, comp - 3) + end if + end function iF_comp + + subroutine system_to_state_copy(self, system, state) + class(flre_zone_t), intent(in) :: self + complex(dp), intent(in) :: system(*) + complex(dp), intent(out) :: state(*) + integer :: k, i, dim_k, i_state, i_sys + do k = 0, 2 + dim_k = get_me_dim_ersp_state(self%me, k) + i_state = get_me_iersp_state(self%me, k) + i_sys = get_me_iersp_sys(self%me, k) + do i = 0, dim_k - 1 + state(i_state + i + 1) = system(i_sys + i + 1) + end do + end do + end subroutine system_to_state_copy + + !> Only the Ersp slots of `system` are written (matching the oracle: + !> "warning: basis array is filled (partly) by state vectors"). + subroutine state_to_system_copy(self, state, system) + class(flre_zone_t), intent(in) :: self + complex(dp), intent(in) :: state(*) + complex(dp), intent(inout) :: system(*) + integer :: k, i, dim_k, i_state, i_sys + do k = 0, 2 + dim_k = get_me_dim_ersp_state(self%me, k) + i_state = get_me_iersp_state(self%me, k) + i_sys = get_me_iersp_sys(self%me, k) + do i = 0, dim_k - 1 + system(i_sys + i + 1) = state(i_state + i + 1) + end do + end do + end subroutine state_to_system_copy + + !> Galilean transform of a state vector (Er,Es,Ep with their radial + !> derivative ladders). Assumes dim_Ersp_state(0)=dim_Ersp_state(1)= + !> dim_Ersp_state(2) (= ho+1), matching the oracle's own implicit + !> assumption (it sizes ht/hz/mor/ks/kp at ho+1 = dim_Ersp_state(2) and + !> reads E1c[1]/E1c[2] up to index ho regardless of their own per- + !> component allocation size). + subroutine galilean_transform_of_flre_state_vector(self, V, omega, rpt, E1, E2) + class(flre_zone_t), intent(in) :: self + real(dp), intent(in) :: V, rpt + complex(dp), intent(in) :: omega + complex(dp), intent(in) :: E1(0:*) + complex(dp), intent(out) :: E2(0:*) + + integer :: dim_Ersp_state(0:2), iErsp_state(0:2), mo(0:2) + integer :: m, ho, o, k + real(dp) :: kz + real(dp), allocatable, target :: Cbin(:, :), htz(:), mor(:), ks(:), kp(:) + real(dp), pointer :: ht(:), hz(:) + real(dp) :: htmor, hzmor + complex(dp), allocatable :: Br(:), Ez(:), htBr(:), hzBr(:) + complex(dp) :: kpEs, ksEp, hzEp, htEs + complex(dp), allocatable :: E1c(:, :), E2c(:, :) + + do k = 0, 2 + dim_Ersp_state(k) = get_me_dim_ersp_state(self%me, k) + iErsp_state(k) = get_me_iersp_state(self%me, k) + end do + mo = dim_Ersp_state - 1 + + m = self%wd%m + kz = real(self%wd%n, dp)/get_background_rtor() + + ho = mo(2) + + allocate (Cbin(0:ho, 0:ho)) + call binomial_coefficients_local(ho, Cbin) + + allocate (htz(0:2*ho + 1)) + call eval_hthz(rpt, 0, ho, c_null_ptr, htz) + ht(0:ho) => htz(0:ho) + hz(0:ho) => htz(ho + 1:2*ho + 1) + + allocate (mor(0:ho)) + mor(0) = real(m, dp)/rpt + do o = 1, ho + mor(o) = (-real(o, dp)/rpt)*mor(o - 1) + end do + + allocate (ks(0:ho), kp(0:ho)) + do o = 0, ho + htmor = calc_deriv_product(ho, Cbin, o, ht, mor) + hzmor = calc_deriv_product(ho, Cbin, o, hz, mor) + ks(o) = hzmor - ht(o)*kz + kp(o) = htmor + hz(o)*kz + end do + + allocate (E1c(0:2, 0:ho), E2c(0:2, 0:ho)) + E1c = (0.0_dp, 0.0_dp) + E2c = (0.0_dp, 0.0_dp) + + do k = 0, 2 + do o = 0, mo(k) + E1c(k, o) = E1(iErsp_state(k) + o) + end do + end do + + allocate (Br(0:ho), Ez(0:ho), htBr(0:ho), hzBr(0:ho)) + + do o = 0, ho + kpEs = calc_deriv_product(ho, Cbin, o, kp, E1c(1, :)) + ksEp = calc_deriv_product(ho, Cbin, o, ks, E1c(2, :)) + + Br(o) = (c/omega)*(ksEp - kpEs) + + htBr(o) = calc_deriv_product(ho, Cbin, o, ht, Br) + hzBr(o) = calc_deriv_product(ho, Cbin, o, hz, Br) + + htEs = calc_deriv_product(ho, Cbin, o, ht, E1c(1, :)) + hzEp = calc_deriv_product(ho, Cbin, o, hz, E1c(2, :)) + + Ez(o) = hzEp - htEs + end do + + do o = 0, mo(0) + E2c(0, o) = E1c(0, o) - V/omega*(kz*E1c(0, o) + im*Ez(o + 1)) + end do + do o = 0, mo(1) + E2c(1, o) = E1c(1, o) + (V/c)*hzBr(o) + end do + do o = 0, mo(2) + E2c(2, o) = E1c(2, o) + (V/c)*htBr(o) + end do + + do k = 0, 2 + do o = 0, mo(k) + E2(iErsp_state(k) + o) = E2c(k, o) + end do + end do + end subroutine galilean_transform_of_flre_state_vector + + !> Galilean transform of a full (E,B) system vector. Same uniform-ho + !> sizing assumption as galilean_transform_of_flre_state_vector, also + !> covering dim_Brsp_sys <= dim_Ersp_sys(2). B2c is set equal to B1c + !> (the oracle's V/c correction terms for B are commented out in the + !> source and never activated); Et/htEr/hzEr are computed but unused, + !> matching the oracle's own dead-but-computed values exactly. + subroutine galilean_transform_of_flre_system_vector(self, V, omega, rpt, EB1, EB2) + class(flre_zone_t), intent(in) :: self + real(dp), intent(in) :: V, rpt + complex(dp), intent(in) :: omega + complex(dp), intent(in) :: EB1(0:*) + complex(dp), intent(out) :: EB2(0:*) + + integer :: dim_Ersp_sys(0:2), iErsp_sys(0:2) + integer :: dim_Brsp_sys(0:2), iBrsp_sys(0:2) + integer :: moe(0:2), mob(0:2) + integer :: m, ho, o, k + real(dp) :: kz + real(dp), allocatable, target :: Cbin(:, :), htz(:), mor(:), ks(:), kp(:) + real(dp), pointer :: ht(:), hz(:) + real(dp) :: htmor, hzmor + complex(dp), allocatable :: E1c(:, :), E2c(:, :), B1c(:, :), B2c(:, :) + complex(dp), allocatable :: Br(:), Ez(:), Et(:), htBr(:), hzBr(:), htEr(:), hzEr(:) + complex(dp) :: kpEs, ksEp, hzEp, htEs, hzEs, htEp + + do k = 0, 2 + dim_Ersp_sys(k) = get_me_dim_ersp_sys(self%me, k) + iErsp_sys(k) = get_me_iersp_sys(self%me, k) + dim_Brsp_sys(k) = get_me_dim_brsp_sys(self%me, k) + iBrsp_sys(k) = get_me_ibrsp_sys(self%me, k) + end do + moe = dim_Ersp_sys - 1 + mob = dim_Brsp_sys - 1 + + m = self%wd%m + kz = real(self%wd%n, dp)/get_background_rtor() + + ho = moe(2) + + allocate (Cbin(0:ho, 0:ho)) + call binomial_coefficients_local(ho, Cbin) + + allocate (htz(0:2*ho + 1)) + call eval_hthz(rpt, 0, ho, c_null_ptr, htz) + ht(0:ho) => htz(0:ho) + hz(0:ho) => htz(ho + 1:2*ho + 1) + + allocate (mor(0:ho)) + mor(0) = real(m, dp)/rpt + do o = 1, ho + mor(o) = (-real(o, dp)/rpt)*mor(o - 1) + end do + + allocate (ks(0:ho), kp(0:ho)) + do o = 0, ho + htmor = calc_deriv_product(ho, Cbin, o, ht, mor) + hzmor = calc_deriv_product(ho, Cbin, o, hz, mor) + ks(o) = hzmor - ht(o)*kz + kp(o) = htmor + hz(o)*kz + end do + + allocate (E1c(0:2, 0:ho), E2c(0:2, 0:ho), B1c(0:2, 0:ho), B2c(0:2, 0:ho)) + E1c = (0.0_dp, 0.0_dp) + E2c = (0.0_dp, 0.0_dp) + B1c = (0.0_dp, 0.0_dp) + B2c = (0.0_dp, 0.0_dp) + + do k = 0, 2 + do o = 0, moe(k) + E1c(k, o) = EB1(iErsp_sys(k) + o) + end do + do o = 0, mob(k) + B1c(k, o) = EB1(iBrsp_sys(k) + o) + end do + end do + + allocate (Br(0:ho), Ez(0:ho), Et(0:ho), htBr(0:ho), hzBr(0:ho), htEr(0:ho), hzEr(0:ho)) + + do o = 0, ho + kpEs = calc_deriv_product(ho, Cbin, o, kp, E1c(1, :)) + ksEp = calc_deriv_product(ho, Cbin, o, ks, E1c(2, :)) + + Br(o) = (c/omega)*(ksEp - kpEs) + + htBr(o) = calc_deriv_product(ho, Cbin, o, ht, Br) + hzBr(o) = calc_deriv_product(ho, Cbin, o, hz, Br) + + htEs = calc_deriv_product(ho, Cbin, o, ht, E1c(1, :)) + hzEp = calc_deriv_product(ho, Cbin, o, hz, E1c(2, :)) + + htEp = calc_deriv_product(ho, Cbin, o, ht, E1c(2, :)) + hzEs = calc_deriv_product(ho, Cbin, o, hz, E1c(1, :)) + + Et(o) = hzEs + htEp + Ez(o) = hzEp - htEs + end do + + do o = 0, mob(2) + htEr(o) = calc_deriv_product(ho, Cbin, o, ht, E1c(0, :)) + hzEr(o) = calc_deriv_product(ho, Cbin, o, hz, E1c(0, :)) + end do + + do o = 0, moe(0) + E2c(0, o) = E1c(0, o) - V/omega*(kz*E1c(0, o) + im*Ez(o + 1)) + end do + do o = 0, moe(1) + E2c(1, o) = E1c(1, o) + (V/c)*hzBr(o) + end do + do o = 0, moe(2) + E2c(2, o) = E1c(2, o) + (V/c)*htBr(o) + end do + + do o = 0, mob(0) + B2c(0, o) = B1c(0, o) + end do + do o = 0, mob(1) + B2c(1, o) = B1c(1, o) + end do + do o = 0, mob(2) + B2c(2, o) = B1c(2, o) + end do + + do k = 0, 2 + do o = 0, moe(k) + EB2(iErsp_sys(k) + o) = E2c(k, o) + end do + do o = 0, mob(k) + EB2(iBrsp_sys(k) + o) = B2c(k, o) + end do + end do + end subroutine galilean_transform_of_flre_system_vector + + !> Transform of a full system vector from (Er,Es,Ep,Br,Bs,Bp) to + !> (Er,Et,Ez,Br,Bt,Bz). Same uniform-ho sizing assumption as the two + !> galilean transforms above. + subroutine transform_of_flre_system_vector_to_cyl_coordinates(self, rpt, EB1, EB2) + class(flre_zone_t), intent(in) :: self + real(dp), intent(in) :: rpt + complex(dp), intent(in) :: EB1(0:*) + complex(dp), intent(out) :: EB2(0:*) + + integer :: dim_Ersp_sys(0:2), iErsp_sys(0:2) + integer :: dim_Brsp_sys(0:2), iBrsp_sys(0:2) + integer :: moe(0:2), mob(0:2) + integer :: ho, o, k + real(dp), allocatable, target :: Cbin(:, :), htz(:) + real(dp), pointer :: ht(:), hz(:) + complex(dp), allocatable :: E1c(:, :), E2c(:, :), B1c(:, :), B2c(:, :) + complex(dp) :: hzAp, htAs, hzAs, htAp + + do k = 0, 2 + dim_Ersp_sys(k) = get_me_dim_ersp_sys(self%me, k) + iErsp_sys(k) = get_me_iersp_sys(self%me, k) + dim_Brsp_sys(k) = get_me_dim_brsp_sys(self%me, k) + iBrsp_sys(k) = get_me_ibrsp_sys(self%me, k) + end do + moe = dim_Ersp_sys - 1 + mob = dim_Brsp_sys - 1 + + ho = moe(2) + + allocate (Cbin(0:ho, 0:ho)) + call binomial_coefficients_local(ho, Cbin) + + allocate (htz(0:2*ho + 1)) + call eval_hthz(rpt, 0, ho, c_null_ptr, htz) + ht(0:ho) => htz(0:ho) + hz(0:ho) => htz(ho + 1:2*ho + 1) + + allocate (E1c(0:2, 0:ho), E2c(0:2, 0:ho), B1c(0:2, 0:ho), B2c(0:2, 0:ho)) + E1c = (0.0_dp, 0.0_dp) + E2c = (0.0_dp, 0.0_dp) + B1c = (0.0_dp, 0.0_dp) + B2c = (0.0_dp, 0.0_dp) + + do k = 0, 2 + do o = 0, moe(k) + E1c(k, o) = EB1(iErsp_sys(k) + o) + end do + do o = 0, mob(k) + B1c(k, o) = EB1(iBrsp_sys(k) + o) + end do + end do + + do o = 0, moe(0) + E2c(0, o) = E1c(0, o) + end do + do o = 0, moe(1) + hzAs = calc_deriv_product(ho, Cbin, o, hz, E1c(1, :)) + htAp = calc_deriv_product(ho, Cbin, o, ht, E1c(2, :)) + E2c(1, o) = hzAs + htAp + end do + do o = 0, moe(2) + hzAp = calc_deriv_product(ho, Cbin, o, hz, E1c(2, :)) + htAs = calc_deriv_product(ho, Cbin, o, ht, E1c(1, :)) + E2c(2, o) = hzAp - htAs + end do + + do o = 0, mob(0) + B2c(0, o) = B1c(0, o) + end do + do o = 0, mob(1) + hzAs = calc_deriv_product(ho, Cbin, o, hz, B1c(1, :)) + htAp = calc_deriv_product(ho, Cbin, o, ht, B1c(2, :)) + B2c(1, o) = hzAs + htAp + end do + do o = 0, mob(2) + hzAp = calc_deriv_product(ho, Cbin, o, hz, B1c(2, :)) + htAs = calc_deriv_product(ho, Cbin, o, ht, B1c(1, :)) + B2c(2, o) = hzAp - htAs + end do + + do k = 0, 2 + do o = 0, moe(k) + EB2(iErsp_sys(k) + o) = E2c(k, o) + end do + do o = 0, mob(k) + EB2(iBrsp_sys(k) + o) = B2c(k, o) + end do + end do + end subroutine transform_of_flre_system_vector_to_cyl_coordinates + + !> calc_derive_of_func_product: fg[n] = sum_k C(n,k)*f(k)*g(n-k). + !> The oracle's only live instantiations are (real,real->real) and + !> (real,complex->complex). + real(dp) function calc_deriv_product_rr(N, Cbin, ordn, f, g) result(fg) + integer, intent(in) :: N, ordn + real(dp), intent(in) :: Cbin(0:N, 0:N), f(0:), g(0:) + integer :: k + fg = 0.0_dp + do k = 0, ordn + fg = fg + Cbin(ordn, k)*f(k)*g(ordn - k) + end do + end function calc_deriv_product_rr + + function calc_deriv_product_rc(N, Cbin, ordn, f, g) result(fg) + integer, intent(in) :: N, ordn + real(dp), intent(in) :: Cbin(0:N, 0:N), f(0:) + complex(dp), intent(in) :: g(0:) + complex(dp) :: fg + integer :: k + fg = (0.0_dp, 0.0_dp) + do k = 0, ordn + fg = fg + Cbin(ordn, k)*f(k)*g(ordn - k) + end do + end function calc_deriv_product_rc + + integer function signum_local(x) result(s) + real(dp), intent(in) :: x + if (x < 0.0_dp) then + s = -1 + else if (x == 0.0_dp) then + s = 0 + else + s = 1 + end if + end function signum_local + + !> Mirrors maxwell_eqs_data.h's inline print_maxwell_eqs_data (header- + !> only C++, not extern "C", so unreachable from Fortran): reads the + !> same fields via this module's own get_me_* getters. + subroutine print_maxwell_eqs_data_local(me) + integer(c_intptr_t), intent(in) :: me + integer :: k, Nw + + write (*, '(a)') '' + write (*, '(a)') 'check Maxwell system parameters:' + write (*, '(a,i0)') 'num_vars=', get_me_num_vars(me) + write (*, '(a,i0)') 'num_eqs=', get_me_num_eqs(me) + write (*, '(a,i0,1x,i0,1x,i0)') 'dim_Ersp_state: ', get_me_dim_ersp_state(me, 0), & + get_me_dim_ersp_state(me, 1), get_me_dim_ersp_state(me, 2) + write (*, '(a,i0,1x,i0,1x,i0)') 'iErsp_state: ', get_me_iersp_state(me, 0), & + get_me_iersp_state(me, 1), get_me_iersp_state(me, 2) + write (*, '(a,i0,1x,i0,1x,i0)') 'dim_Ersp_sys: ', get_me_dim_ersp_sys(me, 0), & + get_me_dim_ersp_sys(me, 1), get_me_dim_ersp_sys(me, 2) + write (*, '(a,i0,1x,i0,1x,i0)') 'iErsp_sys: ', get_me_iersp_sys(me, 0), & + get_me_iersp_sys(me, 1), get_me_iersp_sys(me, 2) + write (*, '(a,i0,1x,i0,1x,i0)') 'dim_Brsp_sys: ', get_me_dim_brsp_sys(me, 0), & + get_me_dim_brsp_sys(me, 1), get_me_dim_brsp_sys(me, 2) + write (*, '(a,i0,1x,i0,1x,i0)') 'iBrsp_sys: ', get_me_ibrsp_sys(me, 0), & + get_me_ibrsp_sys(me, 1), get_me_ibrsp_sys(me, 2) + write (*, '(a,i0,1x,i0,1x,i0)') 'jr der_orders: ', get_me_der_order(me, 0, 0), & + get_me_der_order(me, 0, 1), get_me_der_order(me, 0, 2) + write (*, '(a,i0,1x,i0,1x,i0)') 'js der_orders: ', get_me_der_order(me, 1, 0), & + get_me_der_order(me, 1, 1), get_me_der_order(me, 1, 2) + write (*, '(a,i0,1x,i0,1x,i0)') 'jp der_orders: ', get_me_der_order(me, 2, 0), & + get_me_der_order(me, 2, 1), get_me_der_order(me, 2, 2) + + Nw = get_me_nwaves(me) + do k = 0, Nw - 1 + write (*, '(a,i0,a,i0)') 'sys_ind[', k, '] = ', get_me_sys_ind(me, k) + end do + end subroutine print_maxwell_eqs_data_local + + subroutine to_cstr(str, buf) + character(len=*), intent(in) :: str + character(kind=c_char), intent(out) :: buf(*) + integer :: i, n + n = len_trim(str) + do i = 1, n + buf(i) = str(i:i) + end do + buf(n + 1) = c_null_char + end subroutine to_cstr + + !> ---- bind(C) free-function callbacks (called BY legacy Fortran / + !> still-C++ callers with a zone handle BY REFERENCE) ---- + + subroutine set_equations_settings_c_(ptr, hom_sys, Nwaves, Nfs, Nphys, flag_debug) & + bind(C, name="set_equations_settings_c_") + integer(c_intptr_t), intent(in) :: ptr + integer(c_int), intent(out) :: hom_sys, Nwaves, Nfs, Nphys, flag_debug + class(zone_t), pointer :: z + call handle_to_zone(ptr, z) + select type (z) + type is (flre_zone_t) + hom_sys = z%hom_sys + Nwaves = z%Nwaves + Nfs = z%Nfs + Nphys = 0 + flag_debug = z%flag_debug + end select + end subroutine set_equations_settings_c_ + + subroutine set_conductivity_settings_c_(ptr, flre_order, Nmax, gal_corr, rsp) & + bind(C, name="set_conductivity_settings_c_") + integer(c_intptr_t), intent(in) :: ptr + integer(c_int), intent(out) :: flre_order, Nmax, gal_corr, rsp + class(zone_t), pointer :: z + call handle_to_zone(ptr, z) + select type (z) + type is (flre_zone_t) + flre_order = z%flre_order + Nmax = z%Nmax + gal_corr = z%gal_corr + rsp = z%rsp + end select + end subroutine set_conductivity_settings_c_ + + subroutine set_collisions_settings_c_(ptr, collmod) bind(C, name="set_collisions_settings_c_") + integer(c_intptr_t), intent(in) :: ptr + integer(c_int), intent(out) :: collmod(2) + class(zone_t), pointer :: z + call handle_to_zone(ptr, z) + select type (z) + type is (flre_zone_t) + collmod = z%collmod + end select + end subroutine set_collisions_settings_c_ + + subroutine get_iersp_sys_array_(ptr, iErsp_sys) bind(C, name="get_iersp_sys_array_") + integer(c_intptr_t), intent(in) :: ptr + integer(c_int), intent(out) :: iErsp_sys(*) + class(zone_t), pointer :: z + integer :: k + call handle_to_zone(ptr, z) + select type (z) + type is (flre_zone_t) + do k = 0, 2 + iErsp_sys(k + 1) = get_me_iersp_sys(z%me, k) + 1 + end do + end select + end subroutine get_iersp_sys_array_ + + subroutine get_ibrsp_sys_array_(ptr, iBrsp_sys) bind(C, name="get_ibrsp_sys_array_") + integer(c_intptr_t), intent(in) :: ptr + integer(c_int), intent(out) :: iBrsp_sys(*) + class(zone_t), pointer :: z + integer :: k + call handle_to_zone(ptr, z) + select type (z) + type is (flre_zone_t) + do k = 0, 2 + iBrsp_sys(k + 1) = get_me_ibrsp_sys(z%me, k) + 1 + end do + end select + end subroutine get_ibrsp_sys_array_ + + subroutine get_sys_ind_array_(ptr, sys_ind) bind(C, name="get_sys_ind_array_") + integer(c_intptr_t), intent(in) :: ptr + integer(c_int), intent(out) :: sys_ind(*) + class(zone_t), pointer :: z + integer :: k + call handle_to_zone(ptr, z) + select type (z) + type is (flre_zone_t) + do k = 0, z%Nwaves - 1 + sys_ind(k + 1) = get_me_sys_ind(z%me, k) + 1 + end do + end select + end subroutine get_sys_ind_array_ + + subroutine activate_fortran_modules_for_zone_(ptr) & + bind(C, name="activate_fortran_modules_for_zone_") + integer(c_intptr_t), intent(in) :: ptr + class(zone_t), pointer :: z + call handle_to_zone(ptr, z) + select type (z) + type is (flre_zone_t) + call flre_activate_fortran_modules(z) + end select + end subroutine activate_fortran_modules_for_zone_ + + subroutine deactivate_fortran_modules_for_zone_(ptr) & + bind(C, name="deactivate_fortran_modules_for_zone_") + integer(c_intptr_t), intent(in) :: ptr + class(zone_t), pointer :: z + call handle_to_zone(ptr, z) + select type (z) + type is (flre_zone_t) + call flre_deactivate_fortran_modules(z) + end select + end subroutine deactivate_fortran_modules_for_zone_ + + !> rpt/EB1/EB2: a single radial point and the FULL set of Nwaves basis + !> system vectors there (each Ncomps components), transformed from the + !> moving frame to the lab cylindrical frame -- matches the legacy + !> Fortran caller's `complex(8), dimension(D1,Nw1)` convention + !> (flre.f90's stitching_equations_flre_N1_hommed), so EB1/EB2 here are + !> COMPLEX, not flat real, despite the oracle's `double *` signature. + subroutine calc_flre_basis_in_lab_cyl_frame_with_full_system_vectors_(ptr, rpt, EB1, EB2) & + bind(C, name="calc_flre_basis_in_lab_cyl_frame_with_full_system_vectors_") + integer(c_intptr_t), intent(in) :: ptr + real(dp), intent(in) :: rpt + complex(dp), intent(in) :: EB1(*) + complex(dp), intent(out) :: EB2(*) + class(zone_t), pointer :: z + complex(dp), allocatable :: rhs(:), state(:), sys_mov(:), sys_lab(:) + integer :: num_eqs, k, base + character(kind=c_char) :: flag_back + + call handle_to_zone(ptr, z) + select type (z) + type is (flre_zone_t) + num_eqs = get_me_num_eqs(z%me) + allocate (rhs(num_eqs)) + rhs = (0.0_dp, 0.0_dp) + allocate (state(z%Nwaves), sys_mov(z%Ncomps), sys_lab(z%Ncomps)) + + call flre_activate_fortran_modules(z) + + flag_back = get_background_flag_back() + + do k = 0, z%Nwaves - 1 + base = k*z%Ncomps + call system_to_state_copy(z, EB1(base + 1:base + z%Ncomps), state) + call state2sys(rpt, flag_back, state, sys_mov, rhs) + call galilean_transform_of_flre_system_vector(z, -get_background_V_gal_sys(), & + z%wd%omov, rpt, sys_mov, sys_lab) + call transform_of_flre_system_vector_to_cyl_coordinates( & + z, rpt, sys_lab, EB2(base + 1:base + z%Ncomps)) + end do + + call flre_deactivate_fortran_modules(z) + + deallocate (rhs, state, sys_mov, sys_lab) + end select + end subroutine calc_flre_basis_in_lab_cyl_frame_with_full_system_vectors_ + + !> wave_code_interface.cpp's get_kilca_conductivity_array_ used to + !> `static_cast` a zone* and read ->flre_order/->cp + !> directly; with the hierarchy now Fortran, it gets the same data + !> through these two getters instead. + function flre_zone_get_flre_order_(handle) bind(C, name="flre_zone_get_flre_order_") result(res) + integer(c_intptr_t), value :: handle + integer(c_int) :: res + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + select type (z) + type is (flre_zone_t) + res = z%flre_order + end select + end function flre_zone_get_flre_order_ + + function flre_zone_get_cp_(handle) bind(C, name="flre_zone_get_cp_") result(res) + integer(c_intptr_t), value :: handle + integer(c_intptr_t) :: res + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + select type (z) + type is (flre_zone_t) + res = z%cp + end select + end function flre_zone_get_cp_ + +end module kilca_flre_zone_m diff --git a/KiLCA/flre/maxwell_eqs/eval_sysmat.cpp b/KiLCA/flre/maxwell_eqs/eval_sysmat.cpp deleted file mode 100644 index b9b8b1d0..00000000 --- a/KiLCA/flre/maxwell_eqs/eval_sysmat.cpp +++ /dev/null @@ -1,23 +0,0 @@ -#include -#include -#include -#include - -#include "eval_sysmat.h" - -/*******************************************************************/ - -void eval_diff_sys_matrix_ (const sysmat_profiles *sp, double *r, double *M) -{ -spline_eval_d_ (sp->sidM, 1, r, 0, 0, 0, sp->dimM-1, M); -} - -/*******************************************************************/ - -void eval_diff_sys_matrix_f_ (sysmat_profiles **sp_ptr, double *r, double *M) -{ -const sysmat_profiles *sp = *sp_ptr; -spline_eval_d_ (sp->sidM, 1, r, 0, 0, 0, sp->dimM-1, M); -} - -/*******************************************************************/ diff --git a/KiLCA/flre/maxwell_eqs/eval_sysmat.h b/KiLCA/flre/maxwell_eqs/eval_sysmat.h deleted file mode 100644 index c6b86b5a..00000000 --- a/KiLCA/flre/maxwell_eqs/eval_sysmat.h +++ /dev/null @@ -1,17 +0,0 @@ -#ifndef EVAL_SYSMAT_INCLUDE - -#define EVAL_SYSMAT_INCLUDE - -#include "settings.h" -#include "constants.h" -#include "settings.h" -#include "spline.h" -#include "sysmat_profs.h" - -extern "C" -{ -void eval_diff_sys_matrix_ (const sysmat_profiles *sp, double *r, double *M); -void eval_diff_sys_matrix_f_ (sysmat_profiles **sp_ptr, double *r, double *M); -} - -#endif diff --git a/KiLCA/flre/maxwell_eqs/maxwell_eqs_data.cpp b/KiLCA/flre/maxwell_eqs/maxwell_eqs_data.cpp deleted file mode 100644 index 9e18741c..00000000 --- a/KiLCA/flre/maxwell_eqs/maxwell_eqs_data.cpp +++ /dev/null @@ -1,66 +0,0 @@ -/*! \file maxwell_eqs_data.cpp - \brief The implementation of maxwell_eqs_data class. -*/ - -#include -#include -#include -#include -#include - -#include "maxwell_eqs_data.h" - -/*******************************************************************/ - -void copy_module_data_to_maxwell_eqs_data_struct (maxwell_eqs_data *me) -{ -copy_module_data_to_maxwell_eqs_data_struct_f_ (&(me->num_vars), &(me->num_eqs), me->dim_Ersp_sys, me->iErsp_sys, me->dim_Brsp_sys, me->iBrsp_sys, (int *)me->der_order); - -get_ersp_state_indices_and_dims_f_ ((int *)me->dim_Ersp_state, (int *)me->iErsp_state); - -get_sys_ind_array_f_ (me->sys_ind); - -//in C index starts from 0: -for (int k=0; k<3; k++) -{ - me->iErsp_state[k]--; - me->iErsp_sys[k]--; - me->iBrsp_sys[k]--; -} - -for (int k=0; kNwaves; k++) me->sys_ind[k]--; -} - -/*******************************************************************/ - -void maxwell_eqs_data::print (void) -{ -fprintf (stdout, "\ncheck Maxwell system parameters:"); -fprintf (stdout, "\nnum_vars=%d", num_vars); -fprintf (stdout, "\nnum_eqs=%d", num_eqs); - -fprintf (stdout, "\ndim_Ersp_state: %d %d %d", dim_Ersp_state[0], dim_Ersp_state[1], dim_Ersp_state[2]); - -fprintf (stdout, "\niErsp_state: %d %d %d", iErsp_state[0], iErsp_state[1], iErsp_state[2]); - -fprintf (stdout, "\ndim_Ersp_sys: %d %d %d", dim_Ersp_sys[0], dim_Ersp_sys[1], dim_Ersp_sys[2]); - -fprintf (stdout, "\niErsp_sys: %d %d %d", iErsp_sys[0], iErsp_sys[1], iErsp_sys[2]); - -fprintf (stdout, "\ndim_Brsp_sys: %d %d %d", dim_Brsp_sys[0], dim_Brsp_sys[1], dim_Brsp_sys[2]); - -fprintf (stdout, "\niBrsp_sys: %d %d %d", iBrsp_sys[0], iBrsp_sys[1], iBrsp_sys[2]); - -fprintf (stdout, "\njr der_orders: %d %d %d", der_order[0][0], der_order[0][1], der_order[0][2]); - -fprintf (stdout, "\njs der_orders: %d %d %d", der_order[1][0], der_order[1][1], der_order[1][2]); - -fprintf (stdout, "\njp der_orders: %d %d %d", der_order[2][0], der_order[2][1], der_order[2][2]); - -for (int k=0; k Per-zone snapshot of the Maxwell-equations system layout, formerly the C++ +!> maxwell_eqs_data class. Multiple flre_zone instances can be alive at once, +!> each with its own snapshot (the maxwell_equations Fortran module itself is +!> transient/shared, reused and cleaned between zones), so this uses the same +!> opaque-handle pattern as kilca_spline_m: each instance is heap-allocated and +!> addressed by a C pointer stored as an integer(c_intptr_t) handle. +!> +!> The data-fill calls below bind to the existing C ABI entry points +!> (copy_module_data_to_maxwell_eqs_data_struct_f_, etc.) exactly as the former +!> C++ constructor did, including der_order's C-row-major flat layout, so the +!> values are byte-identical to the original. +module kilca_maxwell_eqs_data_m + use, intrinsic :: iso_c_binding, only: c_int, c_intptr_t, c_ptr, c_loc, c_f_pointer + implicit none + private + + public :: maxwell_eqs_data_create, maxwell_eqs_data_destroy + public :: get_me_num_vars, get_me_num_eqs, get_me_der_order + public :: get_me_dim_ersp_state, get_me_iersp_state + public :: get_me_dim_ersp_sys, get_me_iersp_sys + public :: get_me_dim_brsp_sys, get_me_ibrsp_sys + public :: get_me_sys_ind, get_me_nwaves + + type :: maxwell_eqs_data_t + integer(c_int) :: Nwaves + integer(c_int) :: num_vars, num_eqs + integer(c_int) :: der_order_flat(0:8) + integer(c_int) :: dim_Ersp_state(0:2), iErsp_state(0:2) + integer(c_int) :: dim_Ersp_sys(0:2), iErsp_sys(0:2) + integer(c_int) :: dim_Brsp_sys(0:2), iBrsp_sys(0:2) + integer(c_int), allocatable :: sys_ind(:) + end type maxwell_eqs_data_t + + interface + subroutine copy_module_data_to_maxwell_eqs_data_struct_f(num_vars_p, num_eqs_p, & + dim_Ersp_sys_p, iErsp_sys_p, dim_Brsp_sys_p, iBrsp_sys_p, der_order_p) & + bind(C, name="copy_module_data_to_maxwell_eqs_data_struct_f_") + import :: c_int + integer(c_int), intent(out) :: num_vars_p, num_eqs_p + integer(c_int), intent(out) :: dim_Ersp_sys_p(3), iErsp_sys_p(3) + integer(c_int), intent(out) :: dim_Brsp_sys_p(3), iBrsp_sys_p(3) + integer(c_int), intent(out) :: der_order_p(9) + end subroutine copy_module_data_to_maxwell_eqs_data_struct_f + + subroutine get_ersp_state_indices_and_dims_f(dim_Ersp_state_p, iErsp_state_p) & + bind(C, name="get_ersp_state_indices_and_dims_f_") + import :: c_int + integer(c_int), intent(out) :: dim_Ersp_state_p(3), iErsp_state_p(3) + end subroutine get_ersp_state_indices_and_dims_f + + subroutine get_sys_ind_array_f(sys_ind_p, n) bind(C, name="get_sys_ind_array_f_") + import :: c_int + integer(c_int), value :: n + integer(c_int), intent(out) :: sys_ind_p(n) + end subroutine get_sys_ind_array_f + end interface + +contains + + !> Allocates a new instance and snapshots the current (transient) Fortran + !> maxwell_equations module state into it, applying the same -1 index + !> adjustment (Fortran 1-based -> C 0-based) the former C++ constructor did. + function maxwell_eqs_data_create(Nwaves) result(handle) & + bind(C, name="maxwell_eqs_data_create_") + integer(c_int), value :: Nwaves + integer(c_intptr_t) :: handle + type(maxwell_eqs_data_t), pointer :: me + integer(c_int) :: der_order_flat(9) + integer(c_int) :: i + + allocate (me) + me%Nwaves = Nwaves + + call copy_module_data_to_maxwell_eqs_data_struct_f(me%num_vars, me%num_eqs, & + me%dim_Ersp_sys, me%iErsp_sys, me%dim_Brsp_sys, me%iBrsp_sys, der_order_flat) + me%der_order_flat = der_order_flat + + call get_ersp_state_indices_and_dims_f(me%dim_Ersp_state, me%iErsp_state) + + allocate (me%sys_ind(Nwaves)) + call get_sys_ind_array_f(me%sys_ind, Nwaves) + + do i = 0, 2 + me%iErsp_state(i) = me%iErsp_state(i) - 1 + me%iErsp_sys(i) = me%iErsp_sys(i) - 1 + me%iBrsp_sys(i) = me%iBrsp_sys(i) - 1 + end do + do i = 1, Nwaves + me%sys_ind(i) = me%sys_ind(i) - 1 + end do + + handle = transfer(c_loc(me), handle) + end function maxwell_eqs_data_create + + subroutine maxwell_eqs_data_destroy(handle) bind(C, name="maxwell_eqs_data_destroy_") + integer(c_intptr_t), value :: handle + type(maxwell_eqs_data_t), pointer :: me + + if (handle == 0_c_intptr_t) return + call handle_to_me(handle, me) + if (allocated(me%sys_ind)) deallocate (me%sys_ind) + deallocate (me) + end subroutine maxwell_eqs_data_destroy + + subroutine handle_to_me(handle, me) + integer(c_intptr_t), value :: handle + type(maxwell_eqs_data_t), pointer, intent(out) :: me + type(c_ptr) :: cp + cp = transfer(handle, cp) + call c_f_pointer(cp, me) + end subroutine handle_to_me + + integer(c_int) function get_me_nwaves(handle) bind(C, name="get_me_nwaves_") + integer(c_intptr_t), value :: handle + type(maxwell_eqs_data_t), pointer :: me + call handle_to_me(handle, me) + get_me_nwaves = me%Nwaves + end function get_me_nwaves + + integer(c_int) function get_me_num_vars(handle) bind(C, name="get_me_num_vars_") + integer(c_intptr_t), value :: handle + type(maxwell_eqs_data_t), pointer :: me + call handle_to_me(handle, me) + get_me_num_vars = me%num_vars + end function get_me_num_vars + + integer(c_int) function get_me_num_eqs(handle) bind(C, name="get_me_num_eqs_") + integer(c_intptr_t), value :: handle + type(maxwell_eqs_data_t), pointer :: me + call handle_to_me(handle, me) + get_me_num_eqs = me%num_eqs + end function get_me_num_eqs + + !> Matches the original C++ me->der_order[i][j] (0-based i,j): the C ABI + !> call above filled der_order_flat with C row-major [3][3] layout. + integer(c_int) function get_me_der_order(handle, i, j) bind(C, name="get_me_der_order_") + integer(c_intptr_t), value :: handle + integer(c_int), value :: i, j + type(maxwell_eqs_data_t), pointer :: me + call handle_to_me(handle, me) + get_me_der_order = me%der_order_flat(i*3 + j) + end function get_me_der_order + + integer(c_int) function get_me_dim_ersp_state(handle, k) bind(C, name="get_me_dim_ersp_state_") + integer(c_intptr_t), value :: handle + integer(c_int), value :: k + type(maxwell_eqs_data_t), pointer :: me + call handle_to_me(handle, me) + get_me_dim_ersp_state = me%dim_Ersp_state(k) + end function get_me_dim_ersp_state + + integer(c_int) function get_me_iersp_state(handle, k) bind(C, name="get_me_iersp_state_") + integer(c_intptr_t), value :: handle + integer(c_int), value :: k + type(maxwell_eqs_data_t), pointer :: me + call handle_to_me(handle, me) + get_me_iersp_state = me%iErsp_state(k) + end function get_me_iersp_state + + integer(c_int) function get_me_dim_ersp_sys(handle, k) bind(C, name="get_me_dim_ersp_sys_") + integer(c_intptr_t), value :: handle + integer(c_int), value :: k + type(maxwell_eqs_data_t), pointer :: me + call handle_to_me(handle, me) + get_me_dim_ersp_sys = me%dim_Ersp_sys(k) + end function get_me_dim_ersp_sys + + integer(c_int) function get_me_iersp_sys(handle, k) bind(C, name="get_me_iersp_sys_") + integer(c_intptr_t), value :: handle + integer(c_int), value :: k + type(maxwell_eqs_data_t), pointer :: me + call handle_to_me(handle, me) + get_me_iersp_sys = me%iErsp_sys(k) + end function get_me_iersp_sys + + integer(c_int) function get_me_dim_brsp_sys(handle, k) bind(C, name="get_me_dim_brsp_sys_") + integer(c_intptr_t), value :: handle + integer(c_int), value :: k + type(maxwell_eqs_data_t), pointer :: me + call handle_to_me(handle, me) + get_me_dim_brsp_sys = me%dim_Brsp_sys(k) + end function get_me_dim_brsp_sys + + integer(c_int) function get_me_ibrsp_sys(handle, k) bind(C, name="get_me_ibrsp_sys_") + integer(c_intptr_t), value :: handle + integer(c_int), value :: k + type(maxwell_eqs_data_t), pointer :: me + call handle_to_me(handle, me) + get_me_ibrsp_sys = me%iBrsp_sys(k) + end function get_me_ibrsp_sys + + integer(c_int) function get_me_sys_ind(handle, k) bind(C, name="get_me_sys_ind_") + integer(c_intptr_t), value :: handle + integer(c_int), value :: k + type(maxwell_eqs_data_t), pointer :: me + call handle_to_me(handle, me) + get_me_sys_ind = me%sys_ind(k + 1) + end function get_me_sys_ind + +end module kilca_maxwell_eqs_data_m diff --git a/KiLCA/flre/maxwell_eqs/sysmat_profs.cpp b/KiLCA/flre/maxwell_eqs/sysmat_profs.cpp deleted file mode 100644 index 3f1fc070..00000000 --- a/KiLCA/flre/maxwell_eqs/sysmat_profs.cpp +++ /dev/null @@ -1,184 +0,0 @@ -/*! \file sysmat_profs.cpp - \brief The implementation of sysmat_profiles class. -*/ - -#include -#include -#include -#include -#include -#include - -#include "sysmat_profs.h" -#include "eval_sysmat.h" -#include "shared.h" -#include "adaptive_grid.h" -#include "inout.h" -#include "lapack.h" -#include "flre_zone.h" - -/*******************************************************************/ - -void alloc_sysmatrix_profiles_ (sysmat_profiles **spptr) -{ -sysmat_profiles *sp = new sysmat_profiles; -*spptr = sp; -} - -/*******************************************************************/ - -void sysmat_profiles::calc_and_spline_sysmatrix_profiles (const flre_zone *zone) -{ - //in constructor one should set all parameters depending on external world, and nowhere - //else use a calls to external objects - this is especially apropriate if the class is small. - - //begin of settings section: - - flag_back = new char[8]; - strcpy (flag_back, zone->cp->flag_back); //background flag is the same - - path2linear = new char[1024]; - strcpy (path2linear, zone->cp->path2linear); - - Nwaves = zone->Nwaves; - - N = zone->cp->NC; - - int max_dim = zone->max_dim_c; - - double eps = zone->eps_out; - - int flag_debug = zone->flag_debug; - - double r1 = zone->r1; - double r2 = zone->r2; - double rm = zone->wd->r_res; - - //end of settings section - - dimM = 2*(Nwaves)*(Nwaves); //number of reals in the sys matrix - - R = new double[(N+1)*(dimM)]; //for evaluation - - ind = 0; //x grid index - - int dimxa = 3; - double *xa = new double[dimxa]; - double *ya = new double[dimxa]; - - //arrays for temp adaptive grid: - xt = new double[max_dim]; - yt = new double[(dimM)*max_dim]; - - //boundaries: - xa[0] = r1; - xa[2] = r2; - - - - if (rm != 0.0e0 && (rm > r1 && rm < r2)) xa[1] = 1.01*rm; else xa[1] = 0.5*(xa[0]+xa[2]); - - for (int i=0; i 1) save_M_matrix (10); -} - -/*******************************************************************/ - -void sysmat_profiles::save_M_matrix (int dimf) -{ -/*saving matrix on a fine grid:*/ - -char *filename = new char[1024]; - -int dimt = dimf*(dimx-1); - -double *grid = new double[dimt]; -double *vals = new double[dimM*dimt]; - -for (int i=0; ixt[sp->ind] = *r; - -calc_diff_sys_matrix_ (r, sp->flag_back, sp->yt+(sp->dimM)*(sp->ind), 1); - -//target function: -*f = 0.0e0; - -for (int j=0; jdimM; j++) -{ - (*f) += log(1.0+(sp->yt[j+(sp->dimM)*(sp->ind)])*(sp->yt[j+(sp->dimM)*(sp->ind)])); -} - -(sp->ind)++; -} - -/*******************************************************************/ diff --git a/KiLCA/flre/maxwell_eqs/sysmat_profs.h b/KiLCA/flre/maxwell_eqs/sysmat_profs.h deleted file mode 100644 index 80b5d232..00000000 --- a/KiLCA/flre/maxwell_eqs/sysmat_profs.h +++ /dev/null @@ -1,79 +0,0 @@ -/*! \file sysmat_profs.h - \brief The declaration of sysmat_profiles class. -*/ - -#ifndef SYSMAT_PROFS_INCLUDE - -#define SYSMAT_PROFS_INCLUDE - -#include -#include - -#include "settings.h" -#include "background.h" -#include "wave_data.h" -#include "spline.h" - -/*******************************************************************/ - -/*! \class sysmat_profiles - \brief Class represents ODE system (u' = A*u) matrix evaluated on a grid of radial nodes. -*/ -class sysmat_profiles -{ -public: - char *flag_back; //! ODE system matrix (u' = A*u) evaluated on an adaptive radial grid, formerly +!> the C++ sysmat_profiles class. Per-instance handle (same pattern as +!> kilca_spline_m/kilca_maxwell_eqs_data_m/kilca_disp_profiles_m), addressed +!> the same way the existing mode_data Fortran module already stores it +!> (integer(pp) sp_ptr) -- that bridge is agnostic to whether the handle +!> points at a C++ object or a Fortran one, so no change was needed there. +!> +!> calc_diff_sys_matrix_ and the adaptive-grid callback registration +!> (calc_adaptive_1D_grid_4vector_, a C++ function taking a C function +!> pointer) are called via their existing C ABI entry points, exactly as the +!> former C++ methods did, so the values and grid-refinement behavior are +!> unchanged. Sorting uses fortnum's argsort directly (1-based, native +!> Fortran) instead of the former sort_index_doubles C++ wrapper. +module kilca_sysmat_profiles_m + use, intrinsic :: iso_c_binding, only: c_int, c_intptr_t, c_double, c_char, & + c_ptr, c_funptr, c_funloc, c_loc, c_f_pointer, c_null_ptr + use fortnum_multiroot, only: argsort + implicit none + private + + public :: sysmat_profiles_create, sysmat_profiles_destroy + public :: get_sysmat_sidm, get_sysmat_dimm, get_sysmat_dimx, get_sysmat_x_ptr + public :: get_sysmat_flag_back + + type :: sysmat_profiles_t + character(len=8) :: flag_back + character(len=1024) :: path2linear + integer(c_int) :: N, ind, dimx, Nwaves, dimM + real(c_double), allocatable :: x(:) + real(c_double), allocatable :: M(:) + real(c_double), allocatable :: C(:) + real(c_double), allocatable :: R(:) + integer(c_intptr_t) :: sidM = 0 + real(c_double), allocatable :: xt(:) + real(c_double), allocatable :: yt(:) + end type sysmat_profiles_t + + interface + subroutine calc_diff_sys_matrix_c(r, flagback, Dmat, fb_len) & + bind(C, name="calc_diff_sys_matrix_") + import :: c_double, c_char, c_int + real(c_double), intent(in) :: r + character(kind=c_char), intent(in) :: flagback(*) + real(c_double), intent(out) :: Dmat(*) + integer(c_int), value :: fb_len + end subroutine calc_diff_sys_matrix_c + + subroutine calc_adaptive_1d_grid_4vector(f, p, max_dimx, eps, dimx, x, y) & + bind(C, name="calc_adaptive_1D_grid_4vector_") + import :: c_funptr, c_ptr, c_int, c_double + type(c_funptr), value :: f + type(c_ptr), value :: p + integer(c_int), intent(in) :: max_dimx + real(c_double), intent(inout) :: eps + integer(c_int), intent(inout) :: dimx + real(c_double), intent(in) :: x(*) + real(c_double), intent(in) :: y(*) + end subroutine calc_adaptive_1d_grid_4vector + + subroutine spline_alloc_c(N, styp, dimx, x, Carr, sid) bind(C, name="spline_alloc_") + import :: c_int, c_double, c_intptr_t + integer(c_int), value :: N, styp, dimx + real(c_double), intent(in) :: x(*) + real(c_double), intent(inout) :: Carr(*) + integer(c_intptr_t), intent(out) :: sid + end subroutine spline_alloc_c + + subroutine spline_calc_c(sid, y, Imin, Imax, W, ierr) bind(C, name="spline_calc_") + import :: c_intptr_t, c_double, c_int, c_ptr + integer(c_intptr_t), value :: sid + real(c_double), intent(in) :: y(*) + integer(c_int), value :: Imin, Imax + type(c_ptr), value :: W + integer(c_int), intent(out) :: ierr + end subroutine spline_calc_c + + function save_cmplx_matrix(Nrows, Ncols, Npoints, xgrid, arr, full_name) & + result(ierr) bind(C, name="save_cmplx_matrix") + import :: c_int, c_double, c_char + integer(c_int), value :: Nrows, Ncols, Npoints + real(c_double), intent(in) :: xgrid(*) + real(c_double), intent(in) :: arr(*) + character(kind=c_char), intent(in) :: full_name(*) + integer(c_int) :: ierr + end function save_cmplx_matrix + end interface + +contains + + !> Mirrors sysmat_profiles::calc_and_spline_sysmatrix_profiles, with the + !> former zone->cp->{flag_back,path2linear,NC} and zone->{Nwaves,max_dim_c, + !> eps_out,flag_debug,r1,r2,wd->r_res} reads moved to the caller (flre_zone + !> is still a C++ class; only it can read those fields), passed in directly. + function sysmat_profiles_create(Nwaves, flag_back_p, path2linear_p, NC, & + max_dim, eps_out, flag_debug, r1, r2, rm) result(handle) & + bind(C, name="sysmat_profiles_create_") + integer(c_int), value :: Nwaves, NC, max_dim, flag_debug + type(c_ptr), value :: flag_back_p, path2linear_p + real(c_double), value :: eps_out, r1, r2, rm + integer(c_intptr_t) :: handle + + type(sysmat_profiles_t), pointer :: sp + real(c_double) :: xa(3), ya(3), eps + integer(c_int) :: i, dimxa, ierr + integer(c_int), allocatable :: perm(:) + + allocate (sp) + sp%Nwaves = Nwaves + + call read_c_string(flag_back_p, sp%flag_back) + call read_c_string(path2linear_p, sp%path2linear) + + sp%N = NC + + sp%dimM = 2*Nwaves*Nwaves + allocate (sp%R((sp%N + 1)*sp%dimM)) + + sp%ind = 0 + + allocate (sp%xt(max_dim)) + allocate (sp%yt(sp%dimM*max_dim)) + + xa(1) = r1 + xa(3) = r2 + if (rm /= 0.0d0 .and. (rm > r1 .and. rm < r2)) then + xa(2) = 1.01d0*rm + else + xa(2) = 0.5d0*(xa(1) + xa(3)) + end if + + dimxa = 3 + do i = 1, dimxa + call sample_sysmat_func(xa(i), ya(i), c_loc(sp)) + end do + + eps = eps_out + call calc_adaptive_1d_grid_4vector(c_funloc(sample_sysmat_func), c_loc(sp), & + max_dim, eps, dimxa, xa, ya) + + sp%dimx = dimxa + allocate (sp%x(sp%dimx)) + allocate (sp%M(sp%dimx*sp%dimM)) + allocate (sp%C((sp%N + 1)*sp%dimx*sp%dimM)) + + block + integer(c_int) :: j + allocate (perm(sp%dimx)) + call argsort(sp%xt(1:sp%dimx), perm) + + ! fortnum argsort is an unstable heapsort; the sysmat grid shares + ! zone-boundary nodes (duplicated x), so break exact-key ties by + ! ascending original index, reproducing the oracle's + ! sort_index_doubles (KiLCA/core/shared.cpp) so the spline is + ! well-defined and matches the C++ oracle bit-for-bit. + block + integer :: ta, tb, kk, tmp + ta = 1 + do while (ta <= sp%dimx) + tb = ta + 1 + do while (tb <= sp%dimx) + if (sp%xt(perm(tb)) /= sp%xt(perm(ta))) exit + tb = tb + 1 + end do + do kk = ta + 1, tb - 1 + tmp = perm(kk) + i = kk - 1 + do while (i >= ta) + if (perm(i) <= tmp) exit + perm(i + 1) = perm(i) + i = i - 1 + end do + perm(i + 1) = tmp + end do + ta = tb + end do + end block + + do i = 1, sp%dimx + sp%x(i) = sp%xt(perm(i)) + do j = 0, sp%dimM - 1 + sp%M(i + j*sp%dimx) = sp%yt(j + (perm(i) - 1)*sp%dimM + 1) + end do + end do + end block + deallocate (perm) + deallocate (sp%xt) + deallocate (sp%yt) + + call spline_alloc_c(sp%N, 1, sp%dimx, sp%x, sp%C, sp%sidM) + + call spline_calc_c(sp%sidM, sp%M, 0, sp%dimM - 1, c_null_ptr, ierr) + + if (flag_debug > 1) call sysmat_profiles_save_m(sp, 10) + + handle = transfer(c_loc(sp), handle) + end function sysmat_profiles_create + + subroutine sysmat_profiles_destroy(handle) bind(C, name="sysmat_profiles_destroy_") + integer(c_intptr_t), value :: handle + type(sysmat_profiles_t), pointer :: sp + + if (handle == 0_c_intptr_t) return + call handle_to_sp(handle, sp) + if (allocated(sp%x)) deallocate (sp%x) + if (allocated(sp%M)) deallocate (sp%M) + if (allocated(sp%C)) deallocate (sp%C) + if (allocated(sp%R)) deallocate (sp%R) + deallocate (sp) + end subroutine sysmat_profiles_destroy + + integer(c_intptr_t) function get_sysmat_sidm(handle) bind(C, name="get_sysmat_sidm_") + integer(c_intptr_t), value :: handle + type(sysmat_profiles_t), pointer :: sp + call handle_to_sp(handle, sp) + get_sysmat_sidm = sp%sidM + end function get_sysmat_sidm + + integer(c_int) function get_sysmat_dimm(handle) bind(C, name="get_sysmat_dimm_") + integer(c_intptr_t), value :: handle + type(sysmat_profiles_t), pointer :: sp + call handle_to_sp(handle, sp) + get_sysmat_dimm = sp%dimM + end function get_sysmat_dimm + + integer(c_int) function get_sysmat_dimx(handle) bind(C, name="get_sysmat_dimx_") + integer(c_intptr_t), value :: handle + type(sysmat_profiles_t), pointer :: sp + call handle_to_sp(handle, sp) + get_sysmat_dimx = sp%dimx + end function get_sysmat_dimx + + function get_sysmat_x_ptr(handle) result(ptr) bind(C, name="get_sysmat_x_ptr_") + integer(c_intptr_t), value :: handle + type(c_ptr) :: ptr + type(sysmat_profiles_t), pointer :: sp + call handle_to_sp(handle, sp) + ptr = c_loc(sp%x(1)) + end function get_sysmat_x_ptr + + function get_sysmat_flag_back(handle) result(ch) bind(C, name="get_sysmat_flag_back_") + integer(c_intptr_t), value :: handle + character(kind=c_char) :: ch + type(sysmat_profiles_t), pointer :: sp + call handle_to_sp(handle, sp) + ch = sp%flag_back(1:1) + end function get_sysmat_flag_back + + subroutine handle_to_sp(handle, sp) + integer(c_intptr_t), value :: handle + type(sysmat_profiles_t), pointer, intent(out) :: sp + type(c_ptr) :: cp + cp = transfer(handle, cp) + call c_f_pointer(cp, sp) + end subroutine handle_to_sp + + !> bind(C) callback matching void(double *r, double *f, void *p): mirrors + !> sample_sysmat_func, storing the grid point and evaluated diff-sys-matrix + !> values, with the convergence target being log(1+sum(yt^2)). + subroutine sample_sysmat_func(r, f, p) bind(C) + real(c_double), intent(in) :: r + real(c_double), intent(out) :: f + type(c_ptr), value :: p + type(sysmat_profiles_t), pointer :: sp + integer(c_int) :: j + + call c_f_pointer(p, sp) + + sp%xt(sp%ind + 1) = r + + call calc_diff_sys_matrix_c(r, sp%flag_back, & + sp%yt(sp%dimM*sp%ind + 1:sp%dimM*sp%ind + sp%dimM), 1_c_int) + + f = 0.0d0 + do j = 0, sp%dimM - 1 + f = f + log(1.0d0 + sp%yt(j + sp%dimM*sp%ind + 1)**2) + end do + + sp%ind = sp%ind + 1 + end subroutine sample_sysmat_func + + subroutine sysmat_profiles_save_m(sp, dimf) + type(sysmat_profiles_t), pointer, intent(in) :: sp + integer(c_int), intent(in) :: dimf + real(c_double), allocatable :: grid(:), vals(:) + integer(c_int) :: i, k, idx, dimt, ierr_unused + real(c_double) :: r + character(kind=c_char) :: filename(1024) + character(len=1024) :: fname_f + + dimt = dimf*(sp%dimx - 1) + allocate (grid(dimt)) + allocate (vals(sp%dimM*dimt)) + + do i = 0, sp%dimx - 2 + do k = 0, dimf - 1 + idx = k + dimf*i + r = sp%x(i + 1) + k*(sp%x(i + 2) - sp%x(i + 1))/dimf + grid(idx + 1) = r + call calc_diff_sys_matrix_c(r, sp%flag_back, & + vals(sp%dimM*idx + 1:sp%dimM*idx + sp%dimM), 1_c_int) + end do + end do + + fname_f = trim(sp%path2linear)//'debug-data/amat' + call to_c_string(fname_f, filename) + ierr_unused = save_cmplx_matrix(sp%Nwaves, sp%Nwaves, dimt, grid, vals, filename) + + deallocate (grid) + deallocate (vals) + end subroutine sysmat_profiles_save_m + + subroutine to_c_string(f, c) + use, intrinsic :: iso_c_binding, only: c_null_char + character(*), intent(in) :: f + character(kind=c_char), intent(out) :: c(*) + integer :: i, n + n = len_trim(f) + do i = 1, n + c(i) = f(i:i) + end do + c(n + 1) = c_null_char + end subroutine to_c_string + + subroutine read_c_string(cp, out) + use, intrinsic :: iso_c_binding, only: c_null_char + type(c_ptr), value :: cp + character(*), intent(out) :: out + character(kind=c_char), pointer :: chars(:) + integer :: i, n + + n = len(out) + call c_f_pointer(cp, chars, [n]) + out = '' + do i = 1, n + if (chars(i) == c_null_char) exit + out(i:i) = chars(i) + end do + end subroutine read_c_string + +end module kilca_sysmat_profiles_m diff --git a/KiLCA/flre/quants/calc_flre_quants.cpp b/KiLCA/flre/quants/calc_flre_quants.cpp deleted file mode 100644 index 04b97668..00000000 --- a/KiLCA/flre/quants/calc_flre_quants.cpp +++ /dev/null @@ -1,1410 +0,0 @@ -/*! \file calc_flre_quants.cpp - \brief The implementation of functions declared in calc_flre_quants.h. -*/ - -#include "flre_zone.h" -#include "flre_quants.h" -#include "calc_flre_quants.h" -#include "inout.h" -#include "eval_back.h" -#include "eval_cond.h" -#include "shared.h" -#include "spline.h" -#include "interp.h" - -/*******************************************************************/ - -void calculate_JaE (flre_quants *qp) -{ -for (int k=0; kdimx; k++) -{ - qp->jaE[k] = 0.0e0; - qp->jaEi[k] = 0.0e0; -} - -if (qp->zone->sd->as->wa == 0.0) -{ - calculate_JaE_delta (qp); -} -else -{ - calculate_JaE_distributed (qp); -} -} - -/*******************************************************************/ - -void calculate_JaE_delta (flre_quants *qp) -{ -int ia; - -if (qp->zone->bc1 == BOUNDARY_ANTENNA) -{ - ia = 0; -} -else if (qp->zone->bc2 == BOUNDARY_ANTENNA) -{ - ia = qp->dimx-1; -} -else -{ - return; -} - -//computes total absorbed power as a work of electric field on antenna current -double jsurf[4], jsurft[4]; - -current_density_ (jsurf); -cyl2rsp_ (&(qp->zone->sd->as->ra), jsurf, jsurf+2, jsurft, jsurft+2); - -complex ja[2] = {jsurft[0]+jsurft[1]*I, jsurft[2]+jsurft[3]*I}; //ja_s, ja_p - -int Ncomps = qp->zone->Ncomps; - -int const * iErsp_sys = qp->zone->me->iErsp_sys; - -//electric field at the antenna location: -double Es_re = qp->zone->EB_mov[2*Ncomps*ia + 2*iErsp_sys[1] + 0]; -double Es_im = qp->zone->EB_mov[2*Ncomps*ia + 2*iErsp_sys[1] + 1]; -double Ep_re = qp->zone->EB_mov[2*Ncomps*ia + 2*iErsp_sys[2] + 0]; -double Ep_im = qp->zone->EB_mov[2*Ncomps*ia + 2*iErsp_sys[2] + 1]; - -complex Ef[2] = {Es_re+Es_im*I, Ep_re+Ep_im*I}; //Es_a, Ep_a - -//total energy absorbed in the plasma: = - (work of Ef on Ja) -qp->JaE = 0.5*(qp->vol_fac)*(qp->x[ia])*real(ja[0]*conj(Ef[0]) + ja[1]*conj(Ef[1])); - -if (DEBUG_FLAG) fprintf (stdout, "\nzone %d: - JaE: %le.\n", qp->zone->index, - qp->JaE); - -if (qp->zone->sd->os->flag_emfield > 1) -{ - //save total absorbed energy: - char *full_name = new char[1024]; - - sprintf (full_name, "%szone_%d_JaE.dat", qp->path2linear, qp->zone->index); - save_real_array (1, &(qp->x[ia]), &(qp->JaE), full_name); - - delete [] full_name; -} -} - -/*******************************************************************/ - -void calculate_JaE_distributed (flre_quants *qp) -{ -//!computes total absorbed power as a work of electric field on antenna current - -double Ja_rsp[4]; - -complex ja[2]; -complex Ef[2]; - -int Ncomps = qp->zone->Ncomps; - -int const * iErsp_sys = qp->zone->me->iErsp_sys; - -for (int k=0; kdimx; k++) //over r grid -{ - calc_current_density_r_s_p_ (&(qp->x[k]), Ja_rsp); - - ja[0] = Ja_rsp[0] + Ja_rsp[1]*I; //ja_s(r) - ja[1] = Ja_rsp[2] + Ja_rsp[3]*I; //ja_p(r) - - //electric field: - double Es_re = qp->zone->EB_mov[2*Ncomps*k + 2*iErsp_sys[1] + 0]; - double Es_im = qp->zone->EB_mov[2*Ncomps*k + 2*iErsp_sys[1] + 1]; - double Ep_re = qp->zone->EB_mov[2*Ncomps*k + 2*iErsp_sys[2] + 0]; - double Ep_im = qp->zone->EB_mov[2*Ncomps*k + 2*iErsp_sys[2] + 1]; - - Ef[0] = Es_re + Es_im*I; //Es_a - Ef[1] = Ep_re + Ep_im*I; //Ep_a - - qp->jaE[k] = 0.5*real(ja[0]*conj(Ef[0]) + ja[1]*conj(Ef[1])); -} - -integrate_over_cylinder (qp->dimx, qp->x, qp->jaE, qp->vol_fac, qp->jaEi); - -qp->JaE = qp->jaEi[qp->dimx-1]; - -if (DEBUG_FLAG) fprintf (stdout, "\nzone %d: - JaE: %le.\n", qp->zone->index, - qp->JaE); - -if (qp->zone->sd->os->flag_emfield > 1) -{ - //save total absorbed energy: - char *full_name = new char[1024]; - - sprintf (full_name, "%szone_%d_JaE.dat", qp->path2linear, qp->zone->index); - save_real_array (1, &(qp->x[qp->dimx-1]), &(qp->JaE), full_name); - - sprintf (full_name, "%szone_%d_jaE_dens.dat", qp->path2linear, qp->zone->index); - save_real_array (qp->dimx, qp->x, qp->jaE, full_name); - - sprintf (full_name, "%szone_%d_jaE_int.dat", qp->path2linear, qp->zone->index); - save_real_array (qp->dimx, qp->x, qp->jaEi, full_name); - - delete [] full_name; -} -} - -/*******************************************************************/ - -void calc_current_density (flre_quants *qp) -{ -//!computes amplitudes of the perturbed current density for the given r-node value - -//check yourself that all needed quants are already computed: -if (!(qp->flagC)) -{ - fprintf (stderr, "\n\aerror: consistency check failed in the function '%s' at line %d of the file '%s'.", __FUNCTION__, __LINE__, __FILE__); - return; -} - -//it is fun to consider 1D array as ND one: the same trick is used everythere - -//C matrix: spec=0:1, [type=0:1, s=0..2flreo, i=0:2, j=0:2], (re, im)*/ -//here deriv order=0 - must match to call eval_all_C_matrices() -typedef double cond_C_matrix[2][2][2*(qp->flreo)+1][3][3][2]; -cond_C_matrix &C = *((cond_C_matrix *)qp->C); - -//EM field profiles: {0...dimx}, {0...num_vars}, {re,im} -typedef double em_field_data[qp->dimx][qp->zone->Ncomps][2]; -em_field_data &F = *((em_field_data *)qp->zone->EB_mov); - -complex cd, Cm, Ef; - -int i, j, spec, type, order; - -//in arrays it is asumed that one has 2 types of the current density type=0:1 - -//current density for each r value: {{{re,im},comp={r,s,p},type={0,1},spec={i,e,t}} -typedef double curr_dens[3][2][3][2][qp->dimx]; -curr_dens &CD = *((curr_dens *)(qp->qloc[qp->CURRENT_DENS])); //address of cd is treated as 5D array - -for (spec=0; spec<2; spec++) //over species -{ - for (type=0; type<2; type++) //over current types - { - for (i=0; i<3; i++) //over current density components - { - cd = O; //complex zero - for (j=0; j<3; j++) //over electric field (ef) components - { - for (order=0; order<=qp->zone->me->der_order[i][j]; order++) //derivatives - { - //conductivity component for the given r node: - Cm = C[spec][type][order][i][j][0]+C[spec][type][order][i][j][1]*I; - - //derivative of ef for the given r node: - Ef = F[qp->node][qp->zone->me->iErsp_sys[j]+order][0] + - F[qp->node][qp->zone->me->iErsp_sys[j]+order][1]*I; - - //contribution to the curent: - cd += Cm*Ef; - } - } - CD[spec][type][i][0][qp->node] = real(cd); //stores value to qloc array - CD[spec][type][i][1][qp->node] = imag(cd); //stores value to qloc array - } - } -} - -//total i+e current density: spec=2 -for (type=0; type<2; type++) //over current types -{ - for (i=0; i<3; i++) //over current density components - { - CD[2][type][i][0][qp->node] = CD[0][type][i][0][qp->node] + - CD[1][type][i][0][qp->node]; - - CD[2][type][i][1][qp->node] = CD[0][type][i][1][qp->node] + - CD[1][type][i][1][qp->node]; - } -} -qp->flag[qp->CURRENT_DENS] = 1; //cd is computed -} - -/*******************************************************************/ - -void save_current_density (const flre_quants *qp) -{ -char *filename = new char[1024]; - -char sort[3] = {'i','e','t'}; -char comp[3] = {'r','s','p'}; - -FILE *outfile; - -//current density for each r value: {{{re,im},comp={r,s,p},type={0,1},spec={i,e,t}} -typedef double curr_dens[3][2][3][2][qp->dimx]; -curr_dens &CD = *((curr_dens *)(qp->qloc[qp->CURRENT_DENS])); //address of cd is treated as 5D array - -int i, k, spec, type; - -for (spec=0; spec<3; spec++) //over species -{ - for (type=0; type<2; type++) //over current types - { - for (i=0; i<3; i++) //over current density components - { - //file name: - sprintf (filename, "%szone_%d_%s_dens_%c_%d_%c.dat", qp->path2linear, qp->zone->index, qp->name[qp->CURRENT_DENS], comp[i], type, sort[spec]); - - if (!(outfile = fopen (filename, "w"))) - { - fprintf (stderr, "\nFailed to open file %s\a\n", filename); - } - - for (k=0; kdimx; k++) //over r grid - { - fprintf (outfile, "%.16le\t%.16le\t%.16le\n", - qp->x[k], CD[spec][type][i][0][k], CD[spec][type][i][1][k]); - } - fclose (outfile); - } - } -} - -delete [] filename; - -if (DEBUG_FLAG) fprintf (stdout, "\n%s is saved.", qp->name[qp->CURRENT_DENS]); -} - -/*******************************************************************/ - -void calc_absorbed_power_density (flre_quants *qp) -{ -//check yourself that all needed quants are already computed: -if (!(qp->flag[qp->CURRENT_DENS])) -{ - fprintf (stderr, "\n\aerror: consistency check failed in the function '%s' at line %d of the file '%s'.", __FUNCTION__, __LINE__, __FILE__); - return; -} - -//it is fun to consider 1D array as ND one: the same trick is used everythere - -//EM field profiles: {0...dimx}, {0...num_vars}, {re,im} -typedef double em_field_data[qp->dimx][qp->zone->Ncomps][2]; -em_field_data &F = *((em_field_data *)qp->zone->EB_mov); - -//current density for each r value: {{{re,im},comp={r,s,p},type={0,1},spec={i,e,t}} -typedef double curr_dens[3][2][3][2][qp->dimx]; -curr_dens &CD = *((curr_dens *)(qp->qloc[qp->CURRENT_DENS])); //address of cd is treated as 5D array - -//absorbed power density each r value: //{{re},type={0,1},spec={i,e,t}} -typedef double abs_pow_dens[3][2][qp->dimx]; - -//address of abs pow dens in qloc array treated as 3D array: -abs_pow_dens &APD = *((abs_pow_dens *)(qp->qloc[qp->ABS_POWER_DENS])); - -complex cd, Ef; -double apd; - -for (int spec=0; spec<3; spec++) //over species -{ - for (int type=0; type<2; type++) //over current types - { - apd = 0.0; - for (int i=0; i<3; i++) //over components - { - cd = CD[spec][type][i][0][qp->node] + CD[spec][type][i][1][qp->node]*I; - - Ef = F[qp->node][qp->zone->me->iErsp_sys[i]][0] + - F[qp->node][qp->zone->me->iErsp_sys[i]][1]*I; - - apd += 0.5*real(cd*conj(Ef)); - } - APD[spec][type][qp->node] = apd; - } -} -qp->flag[qp->ABS_POWER_DENS] = 1; //apd is computed -} - -/*******************************************************************/ - -void calc_absorbed_power_in_cylinder (flre_quants *qp) -{ -//check yourself that all needed quants are already computed: -if (!(qp->zone->sd->os->flag_quants[qp->ABS_POWER_DENS])) -{ - fprintf (stderr, "\n\aerror: consistency check failed in the function '%s' at line %d of the file '%s'.", __FUNCTION__, __LINE__, __FILE__); - return; -} - -//it is fun to consider 1D array as ND one: the same trick is used everythere - -//absorbed power at each r value: //{{re},type={0,1},spec={i,e,t}} -typedef double abs_pow[3][2][qp->dimx]; - -//address of abs pow dens in qloc array treated as 3D array: -abs_pow &APD = *((abs_pow *)(qp->qloc[qp->ABS_POWER_DENS])); - -//address of integrated abs pow in qint array treated as 3D array: -abs_pow &API = *((abs_pow *)(qp->qint[qp->ABS_POWER_DENS])); - -for (int spec=0; spec<3; spec++) //over species -{ - for (int type=0; type<2; type++) //over current types - { - integrate_over_cylinder (qp->dimx, qp->x, APD[spec][type], qp->vol_fac, API[spec][type]); - } -} -} - -/*******************************************************************/ - -void save_absorbed_power (const flre_quants *qp) -{ -char *filename = new char[1024]; - -char sort[3] = {'i','e','t'}; - -//absorbed power at each r value: //{{re},type={0,1},spec={i,e,t}} -typedef double abs_pow[3][2][qp->dimx]; - -//address of abs pow dens in qloc array treated as 3D array: -abs_pow &APD = *((abs_pow *)(qp->qloc[qp->ABS_POWER_DENS])); - -//address of integrated abs pow in qint array treated as 3D array: -abs_pow &API = *((abs_pow *)(qp->qint[qp->ABS_POWER_DENS])); - -for (int spec=0; spec<3; spec++) //over species -{ - for (int type=0; type<2; type++) //over current types - { - sprintf (filename, "%szone_%d_%s_dens_%d_%c.dat", qp->path2linear, qp->zone->index, qp->name[qp->ABS_POWER_DENS], type, sort[spec]); - - save_real_array (qp->dimx, qp->x, APD[spec][type], filename); - - sprintf (filename, "%szone_%d_%s_int_%d_%c.dat", qp->path2linear, qp->zone->index, qp->name[qp->ABS_POWER_DENS], type, sort[spec]); - - save_real_array (qp->dimx, qp->x, API[spec][type], filename); - } -} - -delete [] filename; - -if (DEBUG_FLAG) fprintf (stdout, "\n%s is saved.", qp->name[qp->ABS_POWER_DENS]); -} - -/*******************************************************************/ - -void calc_dissipated_power_density (flre_quants *qp) -{ -//calculates dissipated power density, see thesis p. 53 -//check yourself that all needed quants are already computed: -if (!(qp->flagK)) -{ - fprintf (stderr, "\n\aerror: consistency check failed in the function '%s' at line %d of the file '%s'.", __FUNCTION__, __LINE__, __FILE__); - return; -} - -int flreo = qp->flreo; - -//it is fun to consider 1D array as ND one: the same trick is used everythere - -/*K: deriv=0:Dmax, spec=0:1, [type=0:1, p=0:flreo, q=0:flreo, i=0:2, j=0:2], (re, im)*/ -//max derivatives order (1 dimension) must match to real call of eval_all_K_matrices! -typedef double cond_K_matrix[qp->Dmax+1][2][2][flreo+1][flreo+1][3][3][2]; -cond_K_matrix &K = *((cond_K_matrix *)qp->K); - -//EM field profiles: {0...dimx}, {0...num_vars}, {re,im} -typedef double em_field_data[qp->dimx][qp->zone->Ncomps][2]; -em_field_data &F = *((em_field_data *)qp->zone->EB_mov); - -//dissipated power density for each r value: ////{{re},type={0,1,2=1-0},spec={i,e,t}} -typedef double diss_pow_dens[3][3][qp->dimx]; - -//address of diss pow dens in qloc array treated as 3D array: -diss_pow_dens &DPD = *((diss_pow_dens *)(qp->qloc[qp->DISS_POWER_DENS])); - -complex dpd, Km, Ef_1, Ef_2, fac; - -double *charge = qp->zone->sd->bs->charge; - -int i, j, n1, n2, spec, type; - -for (spec=0; spec<2; spec++) //over species -{ - fac = pi*(charge[spec])*(charge[spec])/(qp->zone->wd->omov)/(qp->r); - - for (type=0; type<2; type++) //over current types - { - dpd = O; - for (n1=0; n1<=flreo; n1++) - { - for (n2=0; n2<=flreo; n2++) - { - for (i=0; i<3; i++) - { - for (j=0; j<3; j++) - { - //conductivity K matrix for the given r node: - Km = K[0][spec][type][n1][n2][i][j][0] + - K[0][spec][type][n1][n2][i][j][1]*I; - - //derivative of ef for the given r node: - Ef_1 = F[qp->node][qp->zone->me->iErsp_sys[i]+n1][0] + - F[qp->node][qp->zone->me->iErsp_sys[i]+n1][1]*I; - - Ef_2 = F[qp->node][qp->zone->me->iErsp_sys[j]+n2][0] + - F[qp->node][qp->zone->me->iErsp_sys[j]+n2][1]*I; - - dpd += Km*conj(Ef_1)*Ef_2; - } - } - } - } - DPD[spec][type][qp->node] = real(fac*I*dpd); - } -} - -//total i+e dissipated power density: spec=2 -for (type=0; type<2; type++) //over current types -{ - DPD[2][type][qp->node] = DPD[0][type][qp->node] + DPD[1][type][qp->node]; -} - -for (spec=0; spec<3; spec++) //over species to remove contribution of j_0 -{ - DPD[spec][2][qp->node] = DPD[spec][1][qp->node] - DPD[spec][0][qp->node]; -} - -qp->flag[qp->DISS_POWER_DENS] = 1; //dpd is computed -} - -/*******************************************************************/ - -void calc_dissipated_power_in_cylinder (flre_quants *qp) -{ -//check yourself that all needed quants are already computed: -if (!(qp->zone->sd->os->flag_quants[qp->DISS_POWER_DENS])) -{ - fprintf (stderr, "\n\aerror: consistency check failed in the function '%s' at line %d of the file '%s'.", __FUNCTION__, __LINE__, __FILE__); - return; -} - -//it is fun to consider 1D array as ND one: the same trick is used everythere - -//dissipated power for each r value: ////{{re},type={0,1,2=1-0},spec={i,e,t}} -typedef double diss_pow[3][3][qp->dimx]; - -//address of diss pow density in qloc array treated as 3D array: -diss_pow &DPD = *((diss_pow *)(qp->qloc[qp->DISS_POWER_DENS])); - -//address of integrated abs pow in qint array treated as 3D array: -diss_pow &DPI = *((diss_pow *)(qp->qint[qp->DISS_POWER_DENS])); - -for (int spec=0; spec<3; spec++) //over species -{ - for (int type=0; type<3; type++) //over current types - { - integrate_over_cylinder (qp->dimx, qp->x, DPD[spec][type], qp->vol_fac, DPI[spec][type]); - } -} -} - -/*******************************************************************/ - -void save_dissipated_power (const flre_quants *qp) -{ -char *filename = new char[1024]; - -char sort[3] = {'i','e','t'}; - -//dissipated power for each r value: ////{{re},type={0,1,2=1-0},spec={i,e,t}} -typedef double diss_pow[3][3][qp->dimx]; - -//address of diss pow density in qloc array treated as 3D array: -diss_pow &DPD = *((diss_pow *)(qp->qloc[qp->DISS_POWER_DENS])); - -//address of integrated abs pow in qint array treated as 3D array: -diss_pow &DPI = *((diss_pow *)(qp->qint[qp->DISS_POWER_DENS])); - -for (int spec=0; spec<3; spec++) //over species -{ - for (int type=0; type<3; type++) //over current types - { - sprintf (filename, "%szone_%d_%s_dens_%d_%c.dat", qp->path2linear, qp->zone->index, qp->name[qp->DISS_POWER_DENS], type, sort[spec]); - - save_real_array (qp->dimx, qp->x, DPD[spec][type], filename); - - sprintf (filename, "%szone_%d_%s_int_%d_%c.dat", qp->path2linear, qp->zone->index, qp->name[qp->DISS_POWER_DENS], type, sort[spec]); - - save_real_array (qp->dimx, qp->x, DPI[spec][type], filename); - } -} - -delete [] filename; - -if (DEBUG_FLAG) fprintf (stdout, "\n%s is saved.", qp->name[qp->DISS_POWER_DENS]); -} - -/*******************************************************************/ - -void calc_kinetic_flux (flre_quants *qp) -{ -//calculates radial component of kinetic flux out of the cylinder of radius r, -//see thesis p. 53 for an expression for kinetic flux density - -//check yourself that all needed quants are already computed: -if (!(qp->flagK)) -{ - fprintf (stderr, "\n\aerror: consistency check failed in the function '%s' at line %d of the file '%s'.", __FUNCTION__, __LINE__, __FILE__); - return; -} - -int const & flreo = qp->flreo; - -//it is fun to consider 1D array as ND one: the same trick is used everythere - -/*K: deriv=0:Dmax, spec=0:1, [type=0:1, p=0:flreo, q=0:flreo, i=0:2, j=0:2], (re, im)*/ -//max derivatives order (1 dimension) must match to real call of eval_all_K_matrices! -typedef double cond_K_matrix[qp->Dmax+1][2][2][flreo+1][flreo+1][3][3][2]; -cond_K_matrix &K = *((cond_K_matrix *)qp->K); - -//EM field profiles: {0...dimx}, {0...num_vars}, {re,im} -typedef double em_field_data[qp->dimx][qp->zone->Ncomps][2]; -em_field_data &F = *((em_field_data *)qp->zone->EB_mov); - -//kinetic flux density for each r value: ////{{re},type={0,1,2=1-0},spec={i,e,t}} -typedef double kin_flux[3][3][qp->dimx]; - -//address of kinetic flux dens in qloc array treated as 3D array: -kin_flux &KF = *((kin_flux *)(qp->qloc[qp->KIN_FLUX])); - -//binomial coefficients: //C^k_n = n!/k!/(n-k)! coefficients for n=0..flreo, k=0..n -typedef double binom_coeffs[flreo+1][flreo+1]; //must match to allocation and calc! -binom_coeffs &bico = *((binom_coeffs *)(qp->bico)); - -complex kf, Km, Ef_1, Ef_2, fac; - -double coeff; - -double *charge = qp->zone->sd->bs->charge; - -int i, j, n1, n2, spec, type, p, s; - -for (spec=0; spec<2; spec++) //over species -{ - fac = pi*(charge[spec])*(charge[spec])/(qp->zone->wd->omov)/(qp->r); - - for (type=0; type<2; type++) //over current types - { - kf = O; - for (n1=0; n1<=flreo; n1++) - { - for (n2=0; n2<=flreo; n2++) - { - for (p=0; p<=n1-1; p++) - { - for (s=0; s<=n1-p-1; s++) - { - coeff = pow(-1.0, n1+p)*bico[s][n1-p-1]; //C^k_n->bico[k][n] - - for (i=0; i<3; i++) - { - for (j=0; j<3; j++) - { - //conductivity K matrix for the given r node: - Km = K[n1-p-s-1][spec][type][n1][n2][i][j][0] + - K[n1-p-s-1][spec][type][n1][n2][i][j][1]*I; - - //derivative of ef for the given r node: - Ef_1 = F[qp->node][qp->zone->me->iErsp_sys[i]+p][0] + - F[qp->node][qp->zone->me->iErsp_sys[i]+p][1]*I; - - Ef_2 = F[qp->node][qp->zone->me->iErsp_sys[j]+n2+s][0] + - F[qp->node][qp->zone->me->iErsp_sys[j]+n2+s][1]*I; - - kf += coeff*Km*conj(Ef_1)*Ef_2; - } - } - } - } - } - } - KF[spec][type][qp->node] = real(fac*I*kf)*(qp->vol_fac)*(qp->r); - } -} - -//total i+e kinetic flux: spec=2 -for (type=0; type<2; type++) //over current types -{ - KF[2][type][qp->node] = KF[0][type][qp->node] + KF[1][type][qp->node]; -} - -//removes contribution of j_0: -for (spec=0; spec<3; spec++) -{ - KF[spec][2][qp->node] = KF[spec][1][qp->node] - KF[spec][0][qp->node]; -} - -qp->flag[qp->KIN_FLUX] = 1; //dpd is computed -} - -/*******************************************************************/ - -void save_kinetic_flux (const flre_quants *qp) -{ -char *filename = new char[1024]; - -char sort[3] = {'i','e','t'}; - -//kinetic flux density for each r value: ////{{re},type={0,1,2=1-0},spec={i,e,t}} -typedef double kin_flux[3][3][qp->dimx]; - -//address of kinetic flux dens in qloc array treated as 3D array: -kin_flux &KF = *((kin_flux *)(qp->qloc[qp->KIN_FLUX])); - -for (int spec=0; spec<3; spec++) //over species -{ - for (int type=0; type<3; type++) //over current types - { - //file name: - sprintf (filename, "%szone_%d_%s_%d_%c.dat", qp->path2linear, qp->zone->index, qp->name[qp->KIN_FLUX], type, sort[spec]); - - save_real_array (qp->dimx, qp->x, KF[spec][type], filename); - } -} - -delete [] filename; - -if (DEBUG_FLAG) fprintf (stdout, "\n%s is saved.", qp->name[qp->KIN_FLUX]); -} - -/*******************************************************************/ - -void calc_poynting_flux (flre_quants *qp) -{ -//Poynting flux along r-direction out of the cylinder surface: depends on a radius - -//it is fun to consider 1D array as ND one: the same trick is used everythere - -//EM field profiles: {0...dimx}, {0...num_vars}, {re,im} -typedef double em_field_data[qp->dimx][qp->zone->Ncomps][2]; -em_field_data &F = *((em_field_data *)qp->zone->EB_mov); - -//poynting flux for each r value of the cylinder: //{{re}} -typedef double poy_flux[qp->dimx]; - -//address of poynting flux in qloc array treated as 1D array: -poy_flux &PF = *((poy_flux *)(qp->qloc[qp->POY_FLUX])); - -complex Es, Ep, Bs, Bp; //electric and magnetic fields - -int const * iErsp_sys = qp->zone->me->iErsp_sys; -int const * iBrsp_sys = qp->zone->me->iBrsp_sys; - -Es = F[qp->node][iErsp_sys[1]][0] + F[qp->node][iErsp_sys[1]][1]*I; -Ep = F[qp->node][iErsp_sys[2]][0] + F[qp->node][iErsp_sys[2]][1]*I; -Bs = F[qp->node][iBrsp_sys[1]][0] + F[qp->node][iBrsp_sys[1]][1]*I; -Bp = F[qp->node][iBrsp_sys[2]][0] + F[qp->node][iBrsp_sys[2]][1]*I; - -PF[qp->node] = (qp->vol_fac)*(qp->r)*c/(4.0*pi)*0.5*real(conj(Es)*Bp - conj(Ep)*Bs); - -qp->flag[qp->POY_FLUX] = 1; //PFD is computed -} - -/*******************************************************************/ - -void save_poynting_flux (const flre_quants *qp) -{ -char *filename = new char[1024]; - -//file name: -sprintf (filename, "%szone_%d_%s.dat", qp->path2linear, qp->zone->index, qp->name[qp->POY_FLUX]); - -//poynting flux for each r value of the cylinder: //{{re}} -typedef double poy_flux[qp->dimx]; - -//address of poynting flux in qloc array treated as 1D array: -poy_flux &PF = *((poy_flux *)(qp->qloc[qp->POY_FLUX])); - -save_real_array (qp->dimx, qp->x, PF, filename); - -delete [] filename; - -if (DEBUG_FLAG) fprintf (stdout, "\n%s is saved.", qp->name[qp->POY_FLUX]); -} - -/*******************************************************************/ - -void calculate_field_profiles_poy_test (flre_quants *qp) -{ -// if (qp->flag[qp->ABS_POWER_DENS] == 0) calc_absorbed_power_density (qp); -// if (qp->flag[qp->POY_FLUX] == 0) calc_poynting_flux (qp); - -if (qp->flag[qp->ABS_POWER_DENS] == 0 || qp->flag[qp->POY_FLUX] == 0) -{ - fprintf (stderr, "\n\aerror: consistency check failed in the function '%s' at line %d of the file '%s'.", __FUNCTION__, __LINE__, __FILE__); - return; -} - -//absorbed power density each r value: //{{re},type={0,1},spec={i,e,t}} -typedef double abs_pow_dens[3][2][qp->dimx]; - -//address of abs pow dens in qloc array treated as 3D array: -abs_pow_dens &APD = *((abs_pow_dens *)(qp->qloc[qp->ABS_POWER_DENS])); - -//poynting flux for each r value of the cylinder: //{{re}} -typedef double poy_flux[qp->dimx]; - -//address of poynting flux in qloc array treated as 1D array: -poy_flux &PF = *((poy_flux *)(qp->qloc[qp->POY_FLUX])); - -//splining PF: -double* SPF = new double[(qp->N+1)*(qp->dimx)*1]; - -uintptr_t sidPF; -spline_alloc_ (qp->N, 1, qp->dimx, qp->x, SPF, &sidPF); - -int ierr; -spline_calc_ (sidPF, PF, 0, 0, NULL, &ierr); - -double divPFD; - -double avrg_err = 0.0, max_err = 0.0; - -double *err = new double[qp->dimx]; - -int k, ind = 0; - -for (k=0; kdimx-1; k++) //the last point is excluded -{ - qp->node = k; - qp->r = qp->x[k]; - - spline_eval_d_ (sidPF, 1, &(qp->r), 1, 1, 0, 0, &divPFD); - - divPFD /= -(qp->r)*(qp->vol_fac); - - err[k] = fabs(divPFD - (APD[2][0][k] + qp->jaE[k]))/fmax(1.0, fabs(divPFD)); - - if(err[k] > max_err) - { - max_err = err[k]; - ind = k; - } - - avrg_err += err[k]; -} - -//average error: -avrg_err /= (qp->dimx-1); - -if (DEBUG_FLAG) fprintf (stdout, "\naverage error of the solution: %le.\n", avrg_err); - -if (qp->zone->sd->os->flag_additional > 1) -{ - //save: - char *full_name = new char[1024]; - sprintf (full_name, "%szone_%d_poy_test_err.dat", qp->path2linear, qp->zone->index); - save_real_array (qp->dimx-1, qp->x, err, full_name); - delete [] full_name; -} - -spline_free_ (sidPF); - -delete [] SPF; - -delete [] err; -} - -/*******************************************************************/ - -void calc_total_flux (flre_quants *qp) -{ -//total flux out of the cylinder: must be equal to -//(-1)*(dissipated power density integrated over cylinder of a radius r) - -if (!(qp->flag[qp->KIN_FLUX] && qp->flag[qp->POY_FLUX])) -{ - fprintf (stderr, "\n\aerror: consistency check failed in the function '%s' at line %d of the file '%s'.", __FUNCTION__, __LINE__, __FILE__); - return; -} - -//kinetic flux density for each r value: ////{{re},type={0,1,2=1-0},spec={i,e,t}} -typedef double kin_flux[3][3][qp->dimx]; - -//address of kinetic flux dens in qloc array treated as 3D array: -kin_flux &KF = *((kin_flux *)(qp->qloc[qp->KIN_FLUX])); - -//poynting flux for each r value of the cylinder: //{{re}} -typedef double poy_flux[qp->dimx]; - -//address of poynting flux in qloc array treated as 1D array: -poy_flux &PF = *((poy_flux *)(qp->qloc[qp->POY_FLUX])); - -//total flux for each r value of the cylinder: //{{re}} -typedef double tot_flux[qp->dimx]; - -//address of total flux in qloc array treated as 1D array: -tot_flux &TF = *((tot_flux *)(qp->qloc[qp->TOT_FLUX])); - -TF[qp->node] = PF[qp->node] + KF[2][0][qp->node]; - -qp->flag[qp->TOT_FLUX] = 1; //TF is computed -} - -/*******************************************************************/ - -void save_total_flux (const flre_quants *qp) -{ -char *filename = new char[1024]; - -//file name: -sprintf (filename, "%szone_%d_%s.dat", qp->path2linear, qp->zone->index, qp->name[qp->TOT_FLUX]); - -//total flux for each r value of the cylinder: //{{re}} -typedef double tot_flux[qp->dimx]; - -//address of total flux in qloc array treated as 1D array: -tot_flux &TF = *((tot_flux *)(qp->qloc[qp->TOT_FLUX])); - -save_real_array (qp->dimx, qp->x, TF, filename); - -delete [] filename; - -if (DEBUG_FLAG) fprintf (stdout, "\n%s is saved.", qp->name[qp->TOT_FLUX]); -} - -/*******************************************************************/ - -void calc_splines_for_current_density (flre_quants *qp) -{ -//current density must be already computed: -if (!(qp->zone->sd->os->flag_quants[qp->CURRENT_DENS])) -{ - fprintf (stderr, "\n\aerror: consistency check failed in the function '%s' at line %d of the file '%s'.", __FUNCTION__, __LINE__, __FILE__); - return; -} - -typedef double curr_dens[3][2][3][2][qp->dimx]; - -curr_dens &CD = *((curr_dens *)(qp->qloc[qp->CURRENT_DENS])); - -int type = 0; //basic current density -int comp = 0; //r - component - -for (int spec=0; spec<3; spec++) //over species -{ - for (int part=0; part<2; part++) //(re, im) - { - int ind = (qp->dimx)*(part + 2*(spec)); - for (int k=0; kdimx; k++) //over r grid - { - //[spec][re,im][k]: - qp->Y[ind+k] = CD[spec][type][comp][part][k]; - } - } -} - -int ierr; -spline_calc_ (qp->sidY, qp->Y, 0, qp->nY-1, NULL, &ierr); - -qp->flagS = 1; -} - -/*******************************************************************/ - -void calc_number_density (flre_quants *qp) -{ -//computes complex amplitudes of the density perturbations - -if (!(qp->flagS)) -{ - fprintf (stderr, "\n\aerror: consistency check failed in the function '%s' at line %d of the file '%s'.", __FUNCTION__, __LINE__, __FILE__); - return; -} - -//current density for each r value: {{{re,im},comp={r,s,p},type={0,1},spec={i,e,t}} -typedef double curr_dens[3][2][3][2][qp->dimx]; - -curr_dens &CD = *((curr_dens *)(qp->qloc[qp->CURRENT_DENS])); - -//number density each r value: //{{re,im},spec={i,e,t}} -typedef double number_dens[3][2][qp->dimx]; - -//address of number density in qloc array treated as 3D array: -number_dens &ND = *((number_dens *)(qp->qloc[qp->NUMBER_DENS])); - -//eval wave numbers for given r point: -double kvals[3]; - -char * flag_back = qp->zone->sd->bs->flag_back; - -eval_and_set_background_parameters_spec_independent_ (&(qp->r), flag_back); -eval_and_set_wave_parameters_ (&(qp->r), flag_back); -get_wave_parameters_ (kvals); - -complex j[3], dj[1], nd; - -double djr[2]; - -for (int spec=0; spec<2; spec++) //over species -{ - int type = 0; - for (int i=0; i<3; i++) //over current density components - { - j[i] = CD[spec][type][i][0][qp->node] + CD[spec][type][i][1][qp->node]*I; - } - - int Imin = 2*spec; //index of real part - int Imax = Imin+1; //index of imag part - - spline_eval_d_ (qp->sidY, 1, &(qp->r), 1, 1, Imin, Imax, djr); //[spec][re,im] - - dj[0] = djr[0] + djr[1]*I; - - nd = -I/(qp->zone->wd->omov)/(qp->zone->sd->bs->charge[spec])* - (j[0]/(qp->r) + dj[0] + I*(kvals[1]*j[1] + kvals[2]*j[2])); - - ND[spec][0][qp->node] = real(nd); - ND[spec][1][qp->node] = imag(nd); -} - -//'total' density: enters to the total (j_t = j_i + j_e) current transformation: -//j_t' = j_t - V*(ei*n_i + ee*n_e). -for (int part=0; part<2; part++) //over {re, im} -{ - ND[2][part][qp->node] = ND[0][part][qp->node]*(qp->zone->sd->bs->charge[0]/e) + //i - ND[1][part][qp->node]*(qp->zone->sd->bs->charge[1]/e); //e -} - -qp->flag[qp->NUMBER_DENS] = 1; -} - -/*******************************************************************/ - -void save_number_density (const flre_quants *qp) -{ -char *filename = new char[1024]; - -FILE *outfile; - -char sort[3] = {'i','e','t'}; - -//number density each r value: //{{re,im},spec={i,e,t}} -typedef double number_dens[3][2][qp->dimx]; - -//address of number density in qloc array treated as 3D array: -number_dens &ND = *((number_dens *)(qp->qloc[qp->NUMBER_DENS])); - -for (int spec=0; spec<3; spec++) //over species -{ - //file name: - sprintf (filename, "%szone_%d_%s_%c.dat", qp->path2linear, qp->zone->index, qp->name[qp->NUMBER_DENS], sort[spec]); - - if (!(outfile = fopen (filename, "w"))) - { - fprintf (stderr, "\nFailed to open file %s\a\n", filename); - } - - for (int k=0; kdimx; k++) //over r grid - { - fprintf (outfile, "%.16le\t%.16le\t%.16le\n", qp->x[k], ND[spec][0][k], ND[spec][1][k]); - } - fclose (outfile); -} - -delete [] filename; - -if (DEBUG_FLAG) fprintf (stdout, "\n%s is saved.", qp->name[qp->NUMBER_DENS]); -} - -/*******************************************************************/ - -void calc_lorentz_torque_density (flre_quants *qp) -{ -if (!(qp->flag[qp->NUMBER_DENS])) -{ - fprintf (stderr, "\n\aerror: consistency check failed in the function '%s' at line %d of the file '%s'.", __FUNCTION__, __LINE__, __FILE__); - return; -} - -//current density for each r value: {{{re,im},comp={r,s,p},type={0,1},spec={i,e,t}} -typedef double curr_dens[3][2][3][2][qp->dimx]; - -curr_dens &CD = *((curr_dens *)(qp->qloc[qp->CURRENT_DENS])); - -//EM field profiles: {0...dimx}, {0...num_vars}, {re,im} -typedef double em_field_data[qp->dimx][qp->zone->Ncomps][2]; -em_field_data &F = *((em_field_data *)qp->zone->EB_mov); - -//number density each r value: //{{re,im},spec={i,e,t}} -typedef double number_dens[3][2][qp->dimx]; - -//address of number density in qloc array treated as 3D array: -number_dens &ND = *((number_dens *)(qp->qloc[qp->NUMBER_DENS])); - -//Lorentz torque density: each r value: //{{{re},comp={r,th,z}},spec={i,e,t}} -typedef double lor_torq_dens[3][3][qp->dimx]; - -//address of Lorentz torque density in qloc array treated as 3D array: -lor_torq_dens <D = *((lor_torq_dens *)(qp->qloc[qp->LOR_TORQUE_DENS])); - -double h[3]; -eval_and_set_background_parameters_spec_independent_ (&(qp->r),qp->zone->sd->bs->flag_back); -get_magnetic_field_parameters_ (h); - -complex j_rsp[3], E_rsp[3], B_rsp[3]; //rsp sys -complex j_cyl[3], E_cyl[3], Bc_cyl[3]; //cyl sys - -complex jxBc[3]; //j x B* -complex nd; //density perturbation - -for (int spec=0; spec<2; spec++) //over species (i,e) -{ - int type = 0; - - for (int i=0; i<3; i++) //over components (r,s,p) - { - j_rsp[i] = CD[spec][type][i][0][qp->node] + - CD[spec][type][i][1][qp->node]*I; - - E_rsp[i] = F[qp->node][qp->zone->me->iErsp_sys[i]][0] + - F[qp->node][qp->zone->me->iErsp_sys[i]][1]*I; - - B_rsp[i] = F[qp->node][qp->zone->me->iBrsp_sys[i]][0] + - F[qp->node][qp->zone->me->iBrsp_sys[i]][1]*I; - } - - //transformation to cyl system (r,th,z): - //current density: - j_cyl[0] = j_rsp[0]; - j_cyl[1] = h[2]*j_rsp[1] + h[1]*j_rsp[2]; - j_cyl[2] = h[2]*j_rsp[2] - h[1]*j_rsp[1]; - - //electric field: - E_cyl[0] = E_rsp[0]; - E_cyl[1] = h[2]*E_rsp[1] + h[1]*E_rsp[2]; - E_cyl[2] = h[2]*E_rsp[2] - h[1]*E_rsp[1]; - - //conjugate magnetic field: - Bc_cyl[0] = conj(B_rsp[0]); - Bc_cyl[1] = conj(h[2]*B_rsp[1] + h[1]*B_rsp[2]); - Bc_cyl[2] = conj(h[2]*B_rsp[2] - h[1]*B_rsp[1]); - - vec_product_3D (j_cyl, Bc_cyl, jxBc); - - nd = ND[spec][0][qp->node] + ND[spec][1][qp->node]*I; //density perturbation - - //force density: - for (int i=0; i<3; i++) //over components (r,th,z) - { - LTD[spec][i][qp->node] = 0.5*real((qp->zone->sd->bs->charge[spec])* - nd*conj(E_cyl[i]) + E/c*jxBc[i]); - } - - //torque density: - LTD[spec][1][qp->node] *= qp->r; //T_theta = F_theta*r - LTD[spec][2][qp->node] *= qp->zone->sd->bs->rtor; //T_z = F_z*R -} - -//total torque t = i+e: -for (int i=0; i<3; i++) //over components (r,th,z) -{ - LTD[2][i][qp->node] = LTD[0][i][qp->node] + LTD[1][i][qp->node]; -} - -qp->flag[qp->LOR_TORQUE_DENS] = 1; //LTD is computed -} - -/*******************************************************************/ - -void calc_lorentz_torque_on_cylinder (flre_quants *qp) -{ -if (!(qp->zone->sd->os->flag_quants[qp->LOR_TORQUE_DENS])) -{ - fprintf (stderr, "\n\aerror: consistency check failed in the function '%s' at line %d of the file '%s'.", __FUNCTION__, __LINE__, __FILE__); - return; -} - -//Lorentz torque: each r value: //{{{re},comp={r,th,z}},spec={i,e,t}} -typedef double lor_torq[3][3][qp->dimx]; - -//address of Lorentz torque density in qloc array treated as 3D array: -lor_torq <D = *((lor_torq *)(qp->qloc[qp->LOR_TORQUE_DENS])); - -//address of integrated Lorentz torque in qloc array treated as 3D array: -lor_torq <I = *((lor_torq *)(qp->qint[qp->LOR_TORQUE_DENS])); - -double factor; //must be zero for r component - no total force in r direction - -for (int spec=0; spec<3; spec++) //over species (i,e,t) -{ - for (int i=0; i<3; i++) //over components (r,th,z) - { - if (i == 0) factor = 0.0; else factor = qp->vol_fac; - integrate_over_cylinder (qp->dimx, qp->x, LTD[spec][i], factor, LTI[spec][i]); - } -} -} - -/*******************************************************************/ - -void save_lorentz_torque (const flre_quants *qp) -{ -char *filename = new char[1024]; - -char sort[3] = {'i','e','t'}; -char comp[3] = {'r','t','z'}; - -//Lorentz torque: each r value: //{{{re},comp={r,th,z}},spec={i,e,t}} -typedef double lor_torq[3][3][qp->dimx]; - -//address of Lorentz torque density in qloc array treated as 3D array: -lor_torq <D = *((lor_torq *)(qp->qloc[qp->LOR_TORQUE_DENS])); - -//address of integrated Lorentz torque in qloc array treated as 3D array: -lor_torq <I = *((lor_torq *)(qp->qint[qp->LOR_TORQUE_DENS])); - -for (int spec=0; spec<3; spec++) //over species -{ - for (int i=0; i<3; i++) //over (r,theta,z) - { - //file name: - sprintf (filename, "%szone_%d_%s_dens_%c_%c.dat", qp->path2linear, qp->zone->index, qp->name[qp->LOR_TORQUE_DENS], comp[i], sort[spec]); - - save_real_array (qp->dimx, qp->x, LTD[spec][i], filename); - - sprintf (filename, "%szone_%d_%s_int_%c_%c.dat", qp->path2linear, qp->zone->index, qp->name[qp->LOR_TORQUE_DENS], comp[i], sort[spec]); - - save_real_array (qp->dimx, qp->x, LTI[spec][i], filename); - } -} - -delete [] filename; - -if (DEBUG_FLAG) fprintf (stdout, "\n%s is saved.", qp->name[qp->LOR_TORQUE_DENS]); -} - -/*******************************************************************/ - -void vec_product_3D (complex *a, complex *b, complex *res) -{ -res[0] = (a[1]*b[2] - a[2]*b[1]); -res[1] = -(a[0]*b[2] - a[2]*b[0]); -res[2] = (a[0]*b[1] - a[1]*b[0]); -} - -/*******************************************************************/ - -void integrate_over_cylinder (int dim, double *x, double *q, double vol_fac, double *qi) -{ -//simple trapezoidal formula: must be improved! -qi[0] = 0.0; - -for (int i=1; izone->sd->os->flag_quants[qp->CURRENT_DENS] > 0) -{ - eval_current_dens_in_lab_frame (qp, qp->cdlab); -} - -//current density: -if (qp->zone->sd->os->flag_quants[qp->CURRENT_DENS] > 1) -{ - char lframe[] = "lab"; - char cylcomp[] = "rtz"; - char rspcomp[] = "rsp"; - - double *cd = new double[(qp->dimq[qp->CURRENT_DENS])*(qp->dimx)]; - - eval_current_dens_in_lab_frame (qp, cd); - save_current_density (qp, cd, (const char *)lframe, (const char *)rspcomp); - - eval_current_dens_in_cyl_sys (qp, cd); - save_current_density (qp, cd, (const char *)lframe, (const char *)cylcomp); - - delete [] cd; -} -} - -/*******************************************************************/ - -void eval_current_dens_in_lab_frame (const flre_quants *qp, double *cd) -{ -//!transforms current density to lab frame -//current density for each r value: {{{re,im},comp={r,s,p},type={0,1},spec={i,e,t}} - -typedef double curr_dens[3][2][3][2][qp->dimx]; - -curr_dens &CD = *((curr_dens *)(qp->qloc[qp->CURRENT_DENS])); - -//number density each r value: //{{re,im},spec={i,e,t}} -typedef double number_dens[3][2][qp->dimx]; - -number_dens &ND = *((number_dens *)(qp->qloc[qp->NUMBER_DENS])); - -curr_dens &cude = *((curr_dens *)(cd)); - -complex J; - -double htz[2]; -double vel[3]; - -for (int k=0; kdimx; k++) //over r grid -{ - eval_hthz (qp->x[k], 0, 0, qp->zone->bp, htz); - - vel[0] = 0.0; //r component - vel[1] = - htz[0]*(qp->zone->sd->bs->V_gal_sys); //s component - vel[2] = htz[1]*(qp->zone->sd->bs->V_gal_sys); //p component - - for (int type=0; type<2; type++) //over current types - { - for (int i=0; i<3; i++) //over current density components - { - for (int spec=0; spec<2; spec++) //over species (i,e) - { - //j = j' + e n' V - J = (CD[spec][type][i][0][k] + I*CD[spec][type][i][1][k]) + - (qp->zone->sd->bs->charge[spec])*(vel[i]) * - (ND[spec][0][k] +I*ND[spec][1][k]); - - cude[spec][type][i][0][k] = real(J); - cude[spec][type][i][1][k] = imag(J); - } - //total current density: - cude[2][type][i][0][k] = cude[0][type][i][0][k] + cude[1][type][i][0][k]; - cude[2][type][i][1][k] = cude[0][type][i][1][k] + cude[1][type][i][1][k]; - } - } -} -} - -/*******************************************************************/ - -void eval_current_dens_in_cyl_sys (const flre_quants *qp, double *cd) -{ -//!transforms current density to cylindrical system and overwrites it to cd - -//current density for each r value: {{{re,im},comp={r,s,p},type={0,1},spec={i,e,t}} -typedef double curr_dens[3][2][3][2][qp->dimx]; -curr_dens &cude = *((curr_dens *)(cd)); - -complex Jrsp[3], Jcyl[3]; - -double htz[2]; - -for (int k=0; kdimx; k++) //over r grid -{ - eval_hthz (qp->x[k], 0, 0, qp->zone->bp, htz); - - for (int type=0; type<2; type++) //over current types - { - for (int spec=0; spec<3; spec++) //over species (i,e,t) - { - for (int i=0; i<3; i++) //over current density components - { - Jrsp[i] = cude[spec][type][i][0][k] + I*cude[spec][type][i][1][k]; - } - - //transform to cylyndrical system: - Jcyl[0] = Jrsp[0]; - Jcyl[1] = htz[1]*Jrsp[1] + htz[0]*Jrsp[2]; - Jcyl[2] = - htz[0]*Jrsp[1] + htz[1]*Jrsp[2]; - - for (int i=0; i<3; i++) //over current density components - { - cude[spec][type][i][0][k] = real(Jcyl[i]); - cude[spec][type][i][1][k] = imag(Jcyl[i]); - } - } - } -} -} - -/*******************************************************************/ - -void save_current_density (const flre_quants *qp, double *cd, const char *frame, const char *comp) -{ -char *filename = new char[1024]; - -char sort[3] = {'i','e','t'}; - -FILE *outfile; - -//current density for each r value: {{{re,im},comp={r,s,p},type={0,1},spec={i,e,t}} -typedef double curr_dens[3][2][3][2][qp->dimx]; -curr_dens &cude = *((curr_dens *)(cd)); - -for (int spec=0; spec<3; spec++) //over species -{ - for (int type=0; type<2; type++) //over current types - { - for (int i=0; i<3; i++) //over current density components - { - //file name: - sprintf (filename, "%szone_%d_%s_dens_%c_%d_%c_%s.dat", qp->path2linear, qp->zone->index, qp->name[qp->CURRENT_DENS], comp[i], type, sort[spec], frame); - - if (!(outfile = fopen (filename, "w"))) - { - fprintf (stderr, "\nFailed to open file %s\a\n", filename); - } - - for (int k=0; kdimx; k++) //over r grid - { - fprintf (outfile, "%24.16le\t%24.16le\t%24.16le\n", - qp->x[k], cude[spec][type][i][0][k], cude[spec][type][i][1][k]); - } - fclose (outfile); - } - } -} - -delete [] filename; - -if (DEBUG_FLAG) fprintf (stdout, "\n%s in %s frame in %s coordinates is saved.", qp->name[qp->CURRENT_DENS], frame, comp); -} - -/*******************************************************************/ - -void interp_diss_power_density (const flre_quants *qp, double x, int type, int spec, double * dpd) -{ -//dissipated power density for each r value: ////{{re},type={0,1,2=1-0},spec={i,e,t}} -typedef double diss_pow_dens[3][3][qp->dimx]; - -//address of diss pow dens in qloc array treated as 3D array: -diss_pow_dens & DPD = *((diss_pow_dens *)(qp->qloc[qp->DISS_POWER_DENS])); - -double * xg = qp->x; //radial grid - -double * yg = &DPD[spec][type][0]; //1D array of DPD of a given type and spec - -int deg = 5, ind = 0.5*(qp->dimx); - -eval_neville_polynom (qp->dimx, xg, yg, deg, x, 0, 0, &ind, dpd); -} - -/*******************************************************************/ - -void interp_current_density (const flre_quants *qp, double x, int type, int spec, int comp, double * J) -{ -//current density for each r value: {{{re,im},comp={r,s,p},type={0,1},spec={i,e,t}} -typedef double curr_dens[3][2][3][2][qp->dimx]; -curr_dens & CD = *((curr_dens *)(qp->cdlab)); - -double * xg = qp->x; //radial grid - -double * ygr = CD[spec][type][comp][0]; //1D array of CD of a given type, spec and comp: real -double * ygi = CD[spec][type][comp][1]; //1D array of CD of a given type, spec and comp: imag - -int deg = 5, ind = 0.5*(qp->dimx); - -eval_neville_polynom (qp->dimx, xg, ygr, deg, x, 0, 0, &ind, &J[0]); -eval_neville_polynom (qp->dimx, xg, ygi, deg, x, 0, 0, &ind, &J[1]); -} - -/*******************************************************************/ diff --git a/KiLCA/flre/quants/calc_flre_quants.h b/KiLCA/flre/quants/calc_flre_quants.h deleted file mode 100644 index 7a52c31c..00000000 --- a/KiLCA/flre/quants/calc_flre_quants.h +++ /dev/null @@ -1,83 +0,0 @@ -/*! \file calc_flre_quants.h - \brief The functions used to calculate auxiliary quantities for FLRE zone. -*/ - -#ifndef CALC_FLRE_QUANTS_INCLUDE - -#define CALC_FLRE_QUANTS_INCLUDE - -#include "flre_quants.h" -#include "shared.h" - -/*******************************************************************/ - -extern "C" -{ -void current_density_ (double *); -void cyl2rsp_ (const double *, double *, double *, double *, double *); -void calc_current_density_r_s_p_ (double *, double *); - -void eval_and_set_background_parameters_spec_independent_ (double *r, char *flag_back); -void eval_and_set_wave_parameters_ (double *r, char *flag_back); -void get_wave_parameters_ (double *kvals); -void get_magnetic_field_parameters_ (double *hvals); -} - -void calc_splines_for_current_density (flre_quants *qp); - -void calculate_JaE (flre_quants *qp); -void calculate_JaE_delta (flre_quants *qp); -void calculate_JaE_distributed (flre_quants *qp); - -void save_total_absorbed_power (flre_quants *qp); - -void calc_current_density (flre_quants *qp); -void save_current_density (const flre_quants *qp); - -void calc_absorbed_power_density (flre_quants *qp); -void calc_absorbed_power_in_cylinder (flre_quants *qp); -void save_absorbed_power (const flre_quants *qp); - -void calc_dissipated_power_density (flre_quants *qp); -void calc_dissipated_power_in_cylinder (flre_quants *qp); -void save_dissipated_power (const flre_quants *qp); - -void calc_kinetic_flux (flre_quants *qp); -void save_kinetic_flux (const flre_quants *qp); - -void calc_poynting_flux (flre_quants *qp); -void save_poynting_flux (const flre_quants *qp); - -void calc_total_flux (flre_quants *qp); -void save_total_flux (const flre_quants *qp); - -void calc_number_density (flre_quants *qp); -void save_number_density (const flre_quants *qp); - -void calc_lorentz_torque_density (flre_quants *qp); -void calc_lorentz_torque_on_cylinder (flre_quants *qp); -void save_lorentz_torque (const flre_quants *qp); - -void calculate_field_profiles_poy_test (flre_quants *qp); - -inline int binary_search (double x, const double *xa, int ilo, int ihi); - -void vec_product_3D (complex *a, complex *b, complex *res); - -void integrate_over_cylinder (int dim, double *x, double *q, double vol_fac, double *qi); - -void transform_quants_to_lab_cyl_frame (const flre_quants *qp); - -void eval_current_dens_in_lab_frame (const flre_quants *qp, double *cd); - -void eval_current_dens_in_cyl_sys (const flre_quants *qp, double *cd); - -void save_current_density (const flre_quants *qp, double *cd, const char *frame, const char *comp); - -void interp_diss_power_density (const flre_quants *qp, double x, int type, int spec, double * dpd); - -void interp_current_density (const flre_quants *qp, double x, int type, int spec, int comp, double * J); - -/*******************************************************************/ - -#endif diff --git a/KiLCA/flre/quants/flre_quants.cpp b/KiLCA/flre/quants/flre_quants.cpp deleted file mode 100644 index ecfcc82d..00000000 --- a/KiLCA/flre/quants/flre_quants.cpp +++ /dev/null @@ -1,364 +0,0 @@ -/*! \file flre_quants.cpp - \brief The implementation of flre_quants class. -*/ - -#include - -#include "constants.h" -#include "flre_zone.h" -#include "flre_quants.h" -#include "calc_flre_quants.h" -#include "eval_cond.h" -#include "spline.h" -#include "shared.h" -#include "mode.h" - -/*******************************************************************/ - -flre_quants::flre_quants (flre_zone *Z) -{ -qloc = NULL; -qint = NULL; - -C = NULL; -K = NULL; - -Y = NULL; -S = NULL; -R = NULL; -sidY = 0; - -jaE = NULL; -jaEi = NULL; - -cdlab = NULL; - -set_all_known_quants_parameters (); - -zone = Z; - -//begin external variables: - -double rtor = zone->sd->bs->rtor; - -flreo = zone->flre_order; - -int num_quants = zone->sd->os->num_quants; - -int NK = zone->cp->NK; -int dimK = zone->cp->dimK; - -int NC = zone->cp->NC; -int dimC = zone->cp->dimC; - -dimx = zone->dim; - -x = zone->r; - -//end external variables - -//check: -if (num_quants > num_tot) -{ - fprintf (stderr, "\nerror: flre_quants: illegal value of num_quants: %d\n", num_quants); - exit (1); -} - -path2linear = new char[1024]; - -eval_path_to_linear_data (zone->sd->path2project, zone->wd->m, zone->wd->n, zone->wd->olab, path2linear); - -//factor arising from integration over cylinder surface: -vol_fac = (2.0*pi)*(2.0*pi)*rtor; - -//binomial coefficients used for computing some of the quantities: -bico = new double[(flreo+1)*(flreo+1)]; -binomial_coefficients (flreo, bico); - -//Set parameters in the computational list: -dni = new int[num_tot]; //global indices of the quants from computational list - -numq = 0; -for (int i=0; isd->os->flag_quants[i]) - { - dni[numq] = i; - ind[i] = numq++; - } -} - -if (numq == 0) //no quants to compute -{ - fprintf (stdout, "\nwarning: flre_quants: no quants to compute!\n"); - return; -} - -//arrays allocation: -qloc = new double *[numq]; -qint = new double *[numq]; - -for (int i=0; i flreo)!!! - -N = NC; - -//for jr splines: -nY = 2*1*1*3; - -Y = new double[(dimx)*(nY)]; -S = new double[(N+1)*(dimx)*(nY)]; -R = new double[(N+1)*(nY)]; - -spline_alloc_ (N, 1, dimx, x, S, &sidY); - -jaE = new double[dimx]; -jaEi = new double[dimx]; - -cdlab = new double[(dimq[CURRENT_DENS])*(dimx)]; - -if (DEBUG_FLAG) -{ - fprintf (stdout, "\nThere are %d additional quantities to compute:\n", numq); - for (int i=0; icp; - -//end external variables - -if (numq == 0) return; //no quants to compute - -Dmax = flreo; //actually flreo-1, must be <= NK!!! - -if (Dmax > zone->cp->NK) -{ - fprintf (stdout, "\nerror: calculate_local_profiles: Dmax > NK!!!"); - exit (1); -} - -for (int k=0; ksd->os->flag_quants[i]) calc_quant[i](this); - } -} - -//compute the rest which depends on the previous quants computed on the grid: (derivs) -calc_splines_for_current_density (this); - -calculate_field_profiles_poy_test (this); - -for (int k=0; ksd->os->flag_quants[i]) calc_quant[i](this); - } -} -} - -/*******************************************************************/ - -void flre_quants::set_null_node_state (int k) -{ -node = k; - -r = zone->r[k]; - -for (int i=0; isd->os->flag_quants[ABS_POWER_DENS]) -{ - calc_absorbed_power_in_cylinder (this); -} - -if (zone->sd->os->flag_quants[DISS_POWER_DENS]) -{ - calc_dissipated_power_in_cylinder (this); -} - -if (zone->sd->os->flag_quants[LOR_TORQUE_DENS]) -{ - calc_lorentz_torque_on_cylinder (this); -} -} - -/*******************************************************************/ - -void flre_quants::save_profiles (void) -{ -for (int i=0; isd->os->flag_quants[i] == 2) save_quant[i](this); -} - -/*******************************************************************/ - -inline int binary_search (double x, const double *xa, int ilo, int ihi) -{ -//warning: returns dim-2 for x>=xa[dim-1] - Ok for splines! -while (ihi > ilo+1) -{ - int i = (ihi+ilo)/2; - if (xa[i] > x) ihi = i; - else ilo = i; -} -return ilo; -} - -/*******************************************************************/ diff --git a/KiLCA/flre/quants/flre_quants.h b/KiLCA/flre/quants/flre_quants.h deleted file mode 100644 index b1da4365..00000000 --- a/KiLCA/flre/quants/flre_quants.h +++ /dev/null @@ -1,176 +0,0 @@ -/*! \file flre_quants.h - \brief The declaration of flre_quants class. -*/ - -#ifndef FLRE_QUANTS_INCLUDE - -#define FLRE_QUANTS_INCLUDE - -#include "constants.h" -#include "settings.h" -#include "cond_profs.h" - -/*******************************************************************/ - -typedef void (*calc_func)(class flre_quants *); -typedef void (*save_func)(const class flre_quants *); - -/*******************************************************************/ - -/*! \class flre_quants - \brief The class represents auxiliary quantities (like current densities, dissipated power, etc) in a FLRE zone. -*/ -class flre_quants -{ -public: - class flre_zone *zone; //! Auxiliary FLRE quantities (current/power/flux/density/torque), formerly the +!> C++ flre_quants class. Per-instance handle (same pattern as +!> kilca_cond_profiles_m/kilca_sysmat_profiles_m), since each flre_zone owns +!> its own instance. +!> +!> The C++ class held a FIXED set of 8 quantities (num_tot=8, "add more +!> quants if needed" never exercised) dispatched through calc_quant[]/ +!> save_quant[] function-pointer arrays populated once in the constructor. +!> Since the set is fixed and known at translation time, the dispatch is +!> rendered as direct conditional calls (matching exactly which function +!> fires for which quantity index and loop) instead of literal Fortran +!> procedure-pointer arrays -- behaviorally identical, far less error-prone +!> to hand-translate. For the same reason, qloc[i]/qint[i] (a C++ array of +!> per-quantity heap buffers, sized dimq[i]*dimx and allocated only for +!> requested quantities) becomes 8 separately-named, always-allocated flat +!> arrays: never reading an unallocated buffer was already guaranteed by the +!> oracle's own get_output_flag_quants_/flag[] gating, so always-allocating +!> changes memory footprint in the (untested) all-quantities-off corner case +!> but not observable output. +!> +!> All `if (DEBUG_FLAG) fprintf(...)` blocks from the oracle are dropped: +!> DEBUG_FLAG is a compile-time macro hard-coded 0 in code_settings.h, so +!> these blocks provably never execute (matching the SORT_DISPERSION_PROFILES/ +!> USE_SPLINES_IN_RHS_EVALUATION precedent). save_total_absorbed_power +!> (declared in calc_flre_quants.h) and the file-local `binary_search` are +!> dropped: both have zero definitions/callers anywhere in the live tree. +!> +!> calc_quant/save_quant member functions are called ONLY from within this +!> class's own dispatch methods (never directly by flre_zone.cpp or other +!> files), so they are plain private module subroutines, not bind(C) -- only +!> the handful of true external entry points (create/destroy/ +!> calculate_local_profiles/calculate_integrated_profiles/save_profiles/ +!> calculate_JaE/transform_quants_to_lab_cyl_frame/interp_diss_power_density/ +!> interp_current_density) need bind(C) names. +module kilca_flre_quants_m + use, intrinsic :: iso_c_binding, only: c_int, c_intptr_t, c_double, c_char, & + c_ptr, c_loc, c_f_pointer, c_null_ptr, c_null_char + use kilca_cond_profiles_m, only: eval_all_k_matrices, eval_all_c_matrices, & + get_cond_nc + use kilca_maxwell_eqs_data_m, only: get_me_iersp_sys, get_me_ibrsp_sys, & + get_me_der_order + use kilca_neville_m, only: eval_neville_polynom + implicit none + private + + public :: flre_quants_create, flre_quants_destroy + public :: flre_quants_calculate_local_profiles + public :: flre_quants_calculate_integrated_profiles + public :: flre_quants_save_profiles + public :: flre_quants_calculate_jae + public :: flre_quants_transform_quants_to_lab_cyl_frame + public :: flre_quants_interp_diss_power_density + public :: flre_quants_interp_current_density + + real(c_double), parameter :: pi = 3.141592653589793238462643383279502884197d0 + complex(c_double), parameter :: ii = (0.0d0, 1.0d0) + real(c_double), parameter :: cspeed = 2.9979245800d10 + real(c_double), parameter :: echarge = 4.8032d-10 + integer(c_int), parameter :: boundary_antenna = 4 + + !quants indices, 0-based to match get_output_flag_quants_(i): + integer(c_int), parameter :: current_dens_q = 0 + integer(c_int), parameter :: abs_power_dens_q = 1 + integer(c_int), parameter :: diss_power_dens_q = 2 + integer(c_int), parameter :: kin_flux_q = 3 + integer(c_int), parameter :: poy_flux_q = 4 + integer(c_int), parameter :: tot_flux_q = 5 + integer(c_int), parameter :: number_dens_q = 6 + integer(c_int), parameter :: lor_torque_dens_q = 7 + + type :: flre_quants_t + integer(c_intptr_t) :: zone_cp = 0 + integer(c_intptr_t) :: zone_me = 0 + type(c_ptr) :: zone_bp = c_null_ptr + character(len=1024) :: path2linear + integer(c_int) :: zone_index + integer(c_int) :: bc1, bc2 + real(c_double) :: vol_fac + real(c_double), allocatable :: bico(:) + integer(c_int) :: flreo + integer(c_int) :: dimx + real(c_double), pointer :: x(:) => null() + integer(c_int) :: ncomps + real(c_double), pointer :: eb_mov(:) => null() + complex(c_double) :: wd_omov + + integer(c_int) :: numq + integer(c_int) :: n_spline !spline degree, = NC of cond_profiles + + !per-node state: + real(c_double) :: r + integer(c_int) :: node + logical :: flag_computed(0:7) + logical :: flagC, flagK, flagS + integer(c_int) :: dmax + real(c_double), allocatable :: cmat(:) + real(c_double), allocatable :: kmat(:) + + !spline for current density (jr) vs r: + integer(c_intptr_t) :: sidY = 0 + integer(c_int) :: ny + real(c_double), allocatable :: yarr(:), sarr(:) + + real(c_double) :: jae + real(c_double), allocatable :: jae_arr(:), jaei_arr(:) + real(c_double), allocatable :: cdlab(:) + + !per-quantity local/integrated storage (always allocated; see module doc): + real(c_double), allocatable :: current_dens(:) + real(c_double), allocatable :: abs_pow_dens(:), abs_pow_int(:) + real(c_double), allocatable :: diss_pow_dens(:), diss_pow_int(:) + real(c_double), allocatable :: kin_flux(:) + real(c_double), allocatable :: poy_flux(:) + real(c_double), allocatable :: tot_flux(:) + real(c_double), allocatable :: number_dens(:) + real(c_double), allocatable :: lor_torque_dens(:), lor_torque_int(:) + end type flre_quants_t + + interface + subroutine spline_alloc_c(N, styp, dimx, x, Carr, sid) bind(C, name="spline_alloc_") + import :: c_int, c_double, c_intptr_t + integer(c_int), value :: N, styp, dimx + real(c_double), intent(in) :: x(*) + real(c_double), intent(inout) :: Carr(*) + integer(c_intptr_t), intent(out) :: sid + end subroutine spline_alloc_c + + subroutine spline_calc_c(sid, y, Imin, Imax, W, ierr) bind(C, name="spline_calc_") + import :: c_intptr_t, c_double, c_int, c_ptr + integer(c_intptr_t), value :: sid + real(c_double), intent(in) :: y(*) + integer(c_int), value :: Imin, Imax + type(c_ptr), value :: W + integer(c_int), intent(out) :: ierr + end subroutine spline_calc_c + + subroutine spline_eval_d_c(sid, dimz, z, Dmin, Dmax, Imin, Imax, R) & + bind(C, name="spline_eval_d_") + import :: c_intptr_t, c_double, c_int + integer(c_intptr_t), value :: sid + integer(c_int), value :: dimz, Dmin, Dmax, Imin, Imax + real(c_double), intent(in) :: z(*) + real(c_double), intent(out) :: R(*) + end subroutine spline_eval_d_c + + subroutine spline_free_c(sid) bind(C, name="spline_free_") + import :: c_intptr_t + integer(c_intptr_t), value :: sid + end subroutine spline_free_c + + integer(c_int) function save_real_array_c(dim, xgrid, arr, full_name) & + bind(C, name="save_real_array") + import :: c_int, c_double, c_char + integer(c_int), value :: dim + real(c_double), intent(in) :: xgrid(*), arr(*) + character(kind=c_char), intent(in) :: full_name(*) + end function save_real_array_c + + subroutine current_density_c(jsurf) bind(C, name="current_density_") + import :: c_double + real(c_double), intent(out) :: jsurf(*) + end subroutine current_density_c + + subroutine cyl2rsp_c(ra, jr, jt, js, jp) bind(C, name="cyl2rsp_") + import :: c_double + real(c_double), intent(in) :: ra, jr(*), jt(*) + real(c_double), intent(out) :: js(*), jp(*) + end subroutine cyl2rsp_c + + subroutine calc_current_density_r_s_p_c(r, jrsp) bind(C, name="calc_current_density_r_s_p_") + import :: c_double + real(c_double), intent(in) :: r + real(c_double), intent(out) :: jrsp(*) + end subroutine calc_current_density_r_s_p_c + + subroutine eval_and_set_background_parameters_spec_independent_c(r, flagback, fb_len) & + bind(C, name="eval_and_set_background_parameters_spec_independent_") + import :: c_double, c_char, c_int + real(c_double), intent(in) :: r + character(kind=c_char), intent(in) :: flagback(*) + integer(c_int), value :: fb_len + end subroutine eval_and_set_background_parameters_spec_independent_c + + subroutine eval_and_set_wave_parameters_c(r, flagback, fb_len) & + bind(C, name="eval_and_set_wave_parameters_") + import :: c_double, c_char, c_int + real(c_double), intent(in) :: r + character(kind=c_char), intent(in) :: flagback(*) + integer(c_int), value :: fb_len + end subroutine eval_and_set_wave_parameters_c + + subroutine get_wave_parameters_c(kvals) bind(C, name="get_wave_parameters_") + import :: c_double + real(c_double), intent(out) :: kvals(*) + end subroutine get_wave_parameters_c + + subroutine get_magnetic_field_parameters_c(hvals) bind(C, name="get_magnetic_field_parameters_") + import :: c_double + real(c_double), intent(out) :: hvals(*) + end subroutine get_magnetic_field_parameters_c + + subroutine eval_hthz_c(rval, omin, omax, bp, hout) bind(C, name="eval_hthz_") + import :: c_double, c_int, c_ptr + real(c_double), intent(in) :: rval + integer(c_int), intent(in) :: omin, omax + type(c_ptr), intent(in) :: bp + real(c_double), intent(out) :: hout(*) + end subroutine eval_hthz_c + + function get_antenna_wa_c() result(wa) bind(C, name="get_antenna_wa_") + import :: c_double + real(c_double) :: wa + end function get_antenna_wa_c + + function get_antenna_ra_c() result(ra) bind(C, name="get_antenna_ra_") + import :: c_double + real(c_double) :: ra + end function get_antenna_ra_c + + function get_background_rtor_c() result(rtor) bind(C, name="get_background_rtor_") + import :: c_double + real(c_double) :: rtor + end function get_background_rtor_c + + function get_background_v_gal_sys_c() result(v) bind(C, name="get_background_V_gal_sys_") + import :: c_double + real(c_double) :: v + end function get_background_v_gal_sys_c + + function get_background_charge_c(i) result(ch) bind(C, name="get_background_charge_") + import :: c_int, c_double + integer(c_int), value :: i + real(c_double) :: ch + end function get_background_charge_c + + function get_background_flag_back_c() result(ch) bind(C, name="get_background_flag_back_") + import :: c_char + character(kind=c_char) :: ch + end function get_background_flag_back_c + + function get_output_flag_quants_c(i) result(flag) bind(C, name="get_output_flag_quants_") + import :: c_int + integer(c_int), value :: i + integer(c_int) :: flag + end function get_output_flag_quants_c + + function get_output_flag_emfield_c() result(flag) bind(C, name="get_output_flag_emfield_") + import :: c_int + integer(c_int) :: flag + end function get_output_flag_emfield_c + + function get_output_flag_additional_c() result(flag) bind(C, name="get_output_flag_additional_") + import :: c_int + integer(c_int) :: flag + end function get_output_flag_additional_c + + function get_output_num_quants_c() result(n) bind(C, name="get_output_num_quants_") + import :: c_int + integer(c_int) :: n + end function get_output_num_quants_c + + subroutine binomial_coefficients_c(N, BC) bind(C, name="binomial_coefficients_") + import :: c_int, c_double + integer(c_int), value :: N + real(c_double), intent(out) :: BC(*) + end subroutine binomial_coefficients_c + end interface + +contains + + !flat-index helpers, row-major (rightmost fastest), matching the C + !typedef-cast layouts in calc_flre_quants.cpp exactly (verified against + !the underlying spline-channel formulas in cond_profs_m's iKs/iCs and + !shared.cpp's binomial_coefficients): + + integer(c_int) function idx_f(ncomps, node, comp, part) result(idx) + integer(c_int), intent(in) :: ncomps, node, comp, part + idx = part + 2*(comp + ncomps*node) + end function idx_f + + integer(c_int) function idx_cd(dimx, spec, type_, i, part, node) result(idx) + integer(c_int), intent(in) :: dimx, spec, type_, i, part, node + idx = node + dimx*(part + 2*(i + 3*(type_ + 2*spec))) + end function idx_cd + + integer(c_int) function idx_2(dimx, spec, type_, node) result(idx) + integer(c_int), intent(in) :: dimx, spec, type_, node + idx = node + dimx*type_ + dimx*2*spec + end function idx_2 + + integer(c_int) function idx_3(dimx, spec, type_, node) result(idx) + integer(c_int), intent(in) :: dimx, spec, type_, node + idx = node + dimx*type_ + dimx*3*spec + end function idx_3 + + integer(c_int) function idx_nd(dimx, spec, part, node) result(idx) + integer(c_int), intent(in) :: dimx, spec, part, node + idx = node + dimx*(part + 2*spec) + end function idx_nd + + integer(c_int) function idx_kmat(dimk, flreo, deriv, spec, type_, p, q, i, j, part) result(idx) + integer(c_int), intent(in) :: dimk, flreo, deriv, spec, type_, p, q, i, j, part + idx = deriv*dimk + part + 2*(j + 3*(i + 3*(q + (flreo + 1)*(p + (flreo + 1)*( & + type_ + 2*spec))))) + end function idx_kmat + + integer(c_int) function idx_cmat(flreo, spec, type_, s, i, j, part) result(idx) + integer(c_int), intent(in) :: flreo, spec, type_, s, i, j, part + idx = part + 2*(j + 3*(i + 3*(s + (2*flreo + 1)*(type_ + 2*spec)))) + end function idx_cmat + + integer(c_int) function idx_bico(flreo, k, n) result(idx) + integer(c_int), intent(in) :: flreo, k, n + idx = n + k*(flreo + 1) + end function idx_bico + + subroutine save_arr(dim, xgrid, arr, fname) + integer(c_int), intent(in) :: dim + real(c_double), intent(in) :: xgrid(*), arr(*) + character(len=*), intent(in) :: fname + character(kind=c_char) :: cbuf(len(fname) + 1) + integer :: i, n, ierr_unused + + n = len_trim(fname) + do i = 1, n + cbuf(i) = fname(i:i) + end do + cbuf(n + 1) = c_null_char + ierr_unused = save_real_array_c(dim, xgrid, arr, cbuf) + end subroutine save_arr + + function itoa(n) result(s) + integer(c_int), intent(in) :: n + character(len=12) :: s + write (s, '(i0)') n + end function itoa + + function flre_quants_create(zone_cp, zone_me, zone_bp, path2linear_p, & + flreo, dimx, x_ptr, ncomps, eb_mov_ptr, wd_omov_re, wd_omov_im, & + bc1, bc2, zone_index) result(handle) bind(C, name="flre_quants_create_") + integer(c_intptr_t), value :: zone_cp, zone_me + type(c_ptr), value :: zone_bp, path2linear_p, x_ptr, eb_mov_ptr + integer(c_int), value :: flreo, dimx, ncomps, bc1, bc2, zone_index + real(c_double), value :: wd_omov_re, wd_omov_im + integer(c_intptr_t) :: handle + + type(flre_quants_t), pointer :: qp + integer(c_int) :: i, num_quants, ierr + + allocate (qp) + qp%zone_cp = zone_cp + qp%zone_me = zone_me + qp%zone_bp = zone_bp + call read_c_string(path2linear_p, qp%path2linear) + qp%bc1 = bc1 + qp%bc2 = bc2 + qp%zone_index = zone_index + qp%flreo = flreo + qp%dimx = dimx + call c_f_pointer(x_ptr, qp%x, [dimx]) + qp%ncomps = ncomps + call c_f_pointer(eb_mov_ptr, qp%eb_mov, [2*ncomps*dimx]) + qp%wd_omov = cmplx(wd_omov_re, wd_omov_im, c_double) + + qp%vol_fac = (2.0d0*pi)*(2.0d0*pi)*get_background_rtor_c() + + allocate (qp%bico(0:(flreo + 1)*(flreo + 1) - 1)) + call binomial_coefficients_c(flreo, qp%bico) + + num_quants = get_output_num_quants_c() + + qp%numq = 0 + do i = 0, num_quants - 1 + if (get_output_flag_quants_c(i) /= 0) qp%numq = qp%numq + 1 + end do + + if (qp%numq == 0) then + handle = transfer(c_loc(qp), handle) + return + end if + + ! 1-based (indices 1..N), NOT 0-based: every access site throughout + ! this module uses a uniform idx_2/idx_3/idx_cd/idx_nd(...) + 1 + ! shift (the idx_* helpers themselves return a 0-based flat index + ! in [0, N-1]; the +1 converts that into this array's own 1-based + ! Fortran indexing). Allocating these 0-based instead put the + ! valid range one past the array's declared upper bound. + allocate (qp%current_dens(1:36*dimx)) + allocate (qp%abs_pow_dens(1:6*dimx), qp%abs_pow_int(1:6*dimx)) + allocate (qp%diss_pow_dens(1:9*dimx), qp%diss_pow_int(1:9*dimx)) + allocate (qp%kin_flux(1:9*dimx)) + allocate (qp%poy_flux(1:dimx)) + allocate (qp%tot_flux(1:dimx)) + allocate (qp%number_dens(1:6*dimx)) + allocate (qp%lor_torque_dens(1:9*dimx), qp%lor_torque_int(1:9*dimx)) + + qp%n_spline = get_cond_nc(zone_cp) + + qp%flagC = .false. + qp%flagK = .false. + allocate (qp%cmat(0:(qp%n_spline + 1)*2*2*(2*flreo + 1)*3*3*2 - 1)) + ! 1-based: idx_kmat(...) + 1 is used at every kmat access site + ! (unlike cmat/bico, which are accessed via idx_cmat/idx_bico with + ! NO +1, correctly matching their own 0-based allocation). + allocate (qp%kmat(1:(qp%n_spline + 1)*2*2*2*(flreo + 1)*(flreo + 1)*3*3*2)) + + qp%ny = 2*1*1*3 + ! 1-based: calc_splines_for_current_density's ind+k+1 reaches up to + ! 6*dimx (spec=2, part=1, k=dimx-1), one past a 0-based dimx*ny-1 + ! upper bound. + allocate (qp%yarr(1:dimx*qp%ny)) + allocate (qp%sarr(0:(qp%n_spline + 1)*dimx*qp%ny - 1)) + call spline_alloc_c(qp%n_spline, 1, dimx, qp%x, qp%sarr, qp%sidY) + qp%flagS = .false. + + ! 1-based (indices 1..dimx), NOT 0-based: every access site + ! (calculate_jae, calculate_jae_delta/_distributed, + ! flre_quants_calculate_jae) uses a uniform k+1 shift matching the + ! oracle's 0-based qp->jaE[k]/qp->jaEi[qp->dimx-1] - the array + ! itself must hold dimx elements at indices 1..dimx, not 0..dimx-1. + allocate (qp%jae_arr(1:dimx)) + allocate (qp%jaei_arr(1:dimx)) + + allocate (qp%cdlab(0:2*3*2*3*dimx - 1)) + + handle = transfer(c_loc(qp), handle) + end function flre_quants_create + + subroutine flre_quants_destroy(handle) bind(C, name="flre_quants_destroy_") + integer(c_intptr_t), value :: handle + type(flre_quants_t), pointer :: qp + + if (handle == 0_c_intptr_t) return + call handle_to_qp(handle, qp) + if (qp%sidY /= 0) call spline_free_c(qp%sidY) + deallocate (qp) + end subroutine flre_quants_destroy + + subroutine set_null_node_state(qp, k) + type(flre_quants_t), intent(inout) :: qp + integer(c_int), intent(in) :: k + + qp%node = k + qp%r = qp%x(k + 1) + qp%flag_computed = .false. + qp%flagC = .false. + qp%flagK = .false. + end subroutine set_null_node_state + + subroutine flre_quants_calculate_local_profiles(handle) & + bind(C, name="flre_quants_calculate_local_profiles_") + integer(c_intptr_t), value :: handle + type(flre_quants_t), pointer :: qp + integer(c_int) :: k + + call handle_to_qp(handle, qp) + if (qp%numq == 0) return + + qp%dmax = qp%flreo + + do k = 0, qp%dimx - 1 + call set_null_node_state(qp, k) + + call eval_all_k_matrices(qp%zone_cp, 0, qp%dmax, qp%r, qp%kmat) + qp%flagK = .true. + + call eval_all_c_matrices(qp%zone_cp, 0, 0, qp%r, qp%cmat) + qp%flagC = .true. + + if (get_output_flag_quants_c(current_dens_q) /= 0) call calc_current_density(qp) + if (get_output_flag_quants_c(abs_power_dens_q) /= 0) call calc_absorbed_power_density(qp) + if (get_output_flag_quants_c(diss_power_dens_q) /= 0) call calc_dissipated_power_density(qp) + if (get_output_flag_quants_c(kin_flux_q) /= 0) call calc_kinetic_flux(qp) + if (get_output_flag_quants_c(poy_flux_q) /= 0) call calc_poynting_flux(qp) + if (get_output_flag_quants_c(tot_flux_q) /= 0) call calc_total_flux(qp) + end do + + call calc_splines_for_current_density(qp) + + call calculate_field_profiles_poy_test(qp) + + do k = 0, qp%dimx - 1 + call set_null_node_state(qp, k) + + if (get_output_flag_quants_c(number_dens_q) /= 0) call calc_number_density(qp) + if (get_output_flag_quants_c(lor_torque_dens_q) /= 0) call calc_lorentz_torque_density(qp) + end do + end subroutine flre_quants_calculate_local_profiles + + subroutine flre_quants_calculate_integrated_profiles(handle) & + bind(C, name="flre_quants_calculate_integrated_profiles_") + integer(c_intptr_t), value :: handle + type(flre_quants_t), pointer :: qp + + call handle_to_qp(handle, qp) + + if (get_output_flag_quants_c(abs_power_dens_q) /= 0) call calc_absorbed_power_in_cylinder(qp) + if (get_output_flag_quants_c(diss_power_dens_q) /= 0) call calc_dissipated_power_in_cylinder(qp) + if (get_output_flag_quants_c(lor_torque_dens_q) /= 0) call calc_lorentz_torque_on_cylinder(qp) + end subroutine flre_quants_calculate_integrated_profiles + + subroutine flre_quants_save_profiles(handle) bind(C, name="flre_quants_save_profiles_") + integer(c_intptr_t), value :: handle + type(flre_quants_t), pointer :: qp + + call handle_to_qp(handle, qp) + + if (get_output_flag_quants_c(current_dens_q) == 2) call save_current_density_basic(qp) + if (get_output_flag_quants_c(abs_power_dens_q) == 2) call save_absorbed_power(qp) + if (get_output_flag_quants_c(diss_power_dens_q) == 2) call save_dissipated_power(qp) + if (get_output_flag_quants_c(kin_flux_q) == 2) call save_kinetic_flux(qp) + if (get_output_flag_quants_c(poy_flux_q) == 2) call save_poynting_flux(qp) + if (get_output_flag_quants_c(tot_flux_q) == 2) call save_total_flux(qp) + if (get_output_flag_quants_c(number_dens_q) == 2) call save_number_density(qp) + if (get_output_flag_quants_c(lor_torque_dens_q) == 2) call save_lorentz_torque(qp) + end subroutine flre_quants_save_profiles + + !================================================================== + ! current density + !================================================================== + + subroutine calc_current_density(qp) + type(flre_quants_t), intent(inout) :: qp + integer(c_int) :: i, j, spec, type_, order + complex(c_double) :: cd, cm, ef + + if (.not. qp%flagC) return + + do spec = 0, 1 + do type_ = 0, 1 + do i = 0, 2 + cd = (0.0d0, 0.0d0) + do j = 0, 2 + do order = 0, get_me_der_order(qp%zone_me, i, j) + cm = cmplx(qp%cmat(idx_cmat(qp%flreo, spec, type_, order, i, j, 0)), & + qp%cmat(idx_cmat(qp%flreo, spec, type_, order, i, j, 1)), c_double) + ef = cmplx(qp%eb_mov(idx_f(qp%ncomps, qp%node, get_me_iersp_sys(qp%zone_me, j) + order, 0) + 1), & + qp%eb_mov(idx_f(qp%ncomps, qp%node, & + get_me_iersp_sys(qp%zone_me, j) + order, 1) + 1), c_double) + cd = cd + cm*ef + end do + end do + qp%current_dens(idx_cd(qp%dimx, spec, type_, i, 0, qp%node) + 1) = real(cd, c_double) + qp%current_dens(idx_cd(qp%dimx, spec, type_, i, 1, qp%node) + 1) = aimag(cd) + end do + end do + end do + + do type_ = 0, 1 + do i = 0, 2 + qp%current_dens(idx_cd(qp%dimx, 2, type_, i, 0, qp%node) + 1) = & + qp%current_dens(idx_cd(qp%dimx, 0, type_, i, 0, qp%node) + 1) + & + qp%current_dens(idx_cd(qp%dimx, 1, type_, i, 0, qp%node) + 1) + qp%current_dens(idx_cd(qp%dimx, 2, type_, i, 1, qp%node) + 1) = & + qp%current_dens(idx_cd(qp%dimx, 0, type_, i, 1, qp%node) + 1) + & + qp%current_dens(idx_cd(qp%dimx, 1, type_, i, 1, qp%node) + 1) + end do + end do + + qp%flag_computed(current_dens_q) = .true. + end subroutine calc_current_density + + subroutine save_current_density_basic(qp) + type(flre_quants_t), intent(in) :: qp + character(len=1) :: sort(0:2), comp(0:2) + integer(c_int) :: i, spec, type_ + + sort = ['i', 'e', 't'] + comp = ['r', 's', 'p'] + + do spec = 0, 2 + do type_ = 0, 1 + do i = 0, 2 + call save_arr(qp%dimx, qp%x, qp%current_dens(idx_cd(qp%dimx, spec, type_, i, 0, 0) + 1:), & + trim(qp%path2linear)//'zone_'//trim(itoa(qp%zone_index))// & + '_current_dens_'//comp(i)//'_'//trim(itoa(type_))//'_'//sort(spec)//'.dat') + end do + end do + end do + end subroutine save_current_density_basic + + !================================================================== + ! absorbed power density + !================================================================== + + subroutine calc_absorbed_power_density(qp) + type(flre_quants_t), intent(inout) :: qp + integer(c_int) :: spec, type_, i + complex(c_double) :: cd, ef + real(c_double) :: apd + + if (.not. qp%flag_computed(current_dens_q)) return + + do spec = 0, 2 + do type_ = 0, 1 + apd = 0.0d0 + do i = 0, 2 + cd = cmplx(qp%current_dens(idx_cd(qp%dimx, spec, type_, i, 0, qp%node) + 1), & + qp%current_dens(idx_cd(qp%dimx, spec, type_, i, 1, qp%node) + 1), c_double) + ef = cmplx(qp%eb_mov(idx_f(qp%ncomps, qp%node, get_me_iersp_sys(qp%zone_me, i), 0) + 1), & + qp%eb_mov(idx_f(qp%ncomps, qp%node, get_me_iersp_sys(qp%zone_me, i), 1) + 1), c_double) + apd = apd + 0.5d0*real(cd*conjg(ef), c_double) + end do + qp%abs_pow_dens(idx_2(qp%dimx, spec, type_, qp%node) + 1) = apd + end do + end do + + qp%flag_computed(abs_power_dens_q) = .true. + end subroutine calc_absorbed_power_density + + subroutine calc_absorbed_power_in_cylinder(qp) + type(flre_quants_t), intent(inout) :: qp + integer(c_int) :: spec, type_ + + if (get_output_flag_quants_c(abs_power_dens_q) == 0) return + + do spec = 0, 2 + do type_ = 0, 1 + call integrate_over_cylinder(qp%dimx, qp%x, qp%abs_pow_dens(idx_2(qp%dimx, spec, type_, 0) + 1:), & + qp%vol_fac, qp%abs_pow_int(idx_2(qp%dimx, spec, type_, 0) + 1:)) + end do + end do + end subroutine calc_absorbed_power_in_cylinder + + subroutine save_absorbed_power(qp) + type(flre_quants_t), intent(in) :: qp + character(len=1) :: sort(0:2) + integer(c_int) :: spec, type_ + + sort = ['i', 'e', 't'] + + do spec = 0, 2 + do type_ = 0, 1 + call save_arr(qp%dimx, qp%x, qp%abs_pow_dens(idx_2(qp%dimx, spec, type_, 0) + 1:), & + trim(qp%path2linear)//'zone_'//trim(itoa(qp%zone_index))// & + '_abs_pow_dens_'//trim(itoa(type_))//'_'//sort(spec)//'.dat') + call save_arr(qp%dimx, qp%x, qp%abs_pow_int(idx_2(qp%dimx, spec, type_, 0) + 1:), & + trim(qp%path2linear)//'zone_'//trim(itoa(qp%zone_index))// & + '_abs_pow_int_'//trim(itoa(type_))//'_'//sort(spec)//'.dat') + end do + end do + end subroutine save_absorbed_power + + !================================================================== + ! dissipated power density + !================================================================== + + subroutine calc_dissipated_power_density(qp) + type(flre_quants_t), intent(inout) :: qp + integer(c_int) :: i, j, n1, n2, spec, type_, dimk + complex(c_double) :: dpd, km, ef1, ef2, fac + + if (.not. qp%flagK) return + + dimk = 2*2*(qp%flreo + 1)*(qp%flreo + 1)*3*3*2 + + do spec = 0, 1 + fac = pi*get_background_charge_c(spec)*get_background_charge_c(spec)/qp%wd_omov/qp%r + + do type_ = 0, 1 + dpd = (0.0d0, 0.0d0) + do n1 = 0, qp%flreo + do n2 = 0, qp%flreo + do i = 0, 2 + do j = 0, 2 + km = cmplx(qp%kmat(idx_kmat(dimk, qp%flreo, 0, spec, type_, n1, n2, i, j, 0) + 1), & + qp%kmat(idx_kmat(dimk, qp%flreo, 0, spec, type_, n1, n2, i, j, 1) + 1), c_double) + ef1 = cmplx(qp%eb_mov(idx_f(qp%ncomps, qp%node, get_me_iersp_sys(qp%zone_me, i) + n1, 0) + 1), & + qp%eb_mov(idx_f(qp%ncomps, qp%node, & + get_me_iersp_sys(qp%zone_me, i) + n1, 1) + 1), c_double) + ef2 = cmplx(qp%eb_mov(idx_f(qp%ncomps, qp%node, get_me_iersp_sys(qp%zone_me, j) + n2, 0) + 1), & + qp%eb_mov(idx_f(qp%ncomps, qp%node, & + get_me_iersp_sys(qp%zone_me, j) + n2, 1) + 1), c_double) + dpd = dpd + km*conjg(ef1)*ef2 + end do + end do + end do + end do + qp%diss_pow_dens(idx_3(qp%dimx, spec, type_, qp%node) + 1) = real(fac*ii*dpd, c_double) + end do + end do + + do type_ = 0, 1 + qp%diss_pow_dens(idx_3(qp%dimx, 2, type_, qp%node) + 1) = & + qp%diss_pow_dens(idx_3(qp%dimx, 0, type_, qp%node) + 1) + & + qp%diss_pow_dens(idx_3(qp%dimx, 1, type_, qp%node) + 1) + end do + + do spec = 0, 2 + qp%diss_pow_dens(idx_3(qp%dimx, spec, 2, qp%node) + 1) = & + qp%diss_pow_dens(idx_3(qp%dimx, spec, 1, qp%node) + 1) - & + qp%diss_pow_dens(idx_3(qp%dimx, spec, 0, qp%node) + 1) + end do + + qp%flag_computed(diss_power_dens_q) = .true. + end subroutine calc_dissipated_power_density + + subroutine calc_dissipated_power_in_cylinder(qp) + type(flre_quants_t), intent(inout) :: qp + integer(c_int) :: spec, type_ + + if (get_output_flag_quants_c(diss_power_dens_q) == 0) return + + do spec = 0, 2 + do type_ = 0, 2 + call integrate_over_cylinder(qp%dimx, qp%x, qp%diss_pow_dens(idx_3(qp%dimx, spec, type_, 0) + 1:), & + qp%vol_fac, qp%diss_pow_int(idx_3(qp%dimx, spec, type_, 0) + 1:)) + end do + end do + end subroutine calc_dissipated_power_in_cylinder + + subroutine save_dissipated_power(qp) + type(flre_quants_t), intent(in) :: qp + character(len=1) :: sort(0:2) + integer(c_int) :: spec, type_ + + sort = ['i', 'e', 't'] + + do spec = 0, 2 + do type_ = 0, 2 + call save_arr(qp%dimx, qp%x, qp%diss_pow_dens(idx_3(qp%dimx, spec, type_, 0) + 1:), & + trim(qp%path2linear)//'zone_'//trim(itoa(qp%zone_index))// & + '_dis_pow_dens_'//trim(itoa(type_))//'_'//sort(spec)//'.dat') + call save_arr(qp%dimx, qp%x, qp%diss_pow_int(idx_3(qp%dimx, spec, type_, 0) + 1:), & + trim(qp%path2linear)//'zone_'//trim(itoa(qp%zone_index))// & + '_dis_pow_int_'//trim(itoa(type_))//'_'//sort(spec)//'.dat') + end do + end do + end subroutine save_dissipated_power + + !================================================================== + ! kinetic flux + !================================================================== + + subroutine calc_kinetic_flux(qp) + type(flre_quants_t), intent(inout) :: qp + integer(c_int) :: i, j, n1, n2, spec, type_, p, s, dimk + complex(c_double) :: kf, km, ef1, ef2, fac + real(c_double) :: coeff + + if (.not. qp%flagK) return + + dimk = 2*2*(qp%flreo + 1)*(qp%flreo + 1)*3*3*2 + + do spec = 0, 1 + fac = pi*get_background_charge_c(spec)*get_background_charge_c(spec)/qp%wd_omov/qp%r + + do type_ = 0, 1 + kf = (0.0d0, 0.0d0) + do n1 = 0, qp%flreo + do n2 = 0, qp%flreo + do p = 0, n1 - 1 + do s = 0, n1 - p - 1 + coeff = (-1.0d0)**(n1 + p)*qp%bico(idx_bico(qp%flreo, s, n1 - p - 1)) + do i = 0, 2 + do j = 0, 2 + km = cmplx(qp%kmat(idx_kmat(dimk, qp%flreo, n1 - p - s - 1, & + spec, type_, n1, n2, i, j, 0) + 1), & + qp%kmat(idx_kmat(dimk, qp%flreo, n1 - p - s - 1, & + spec, type_, n1, n2, i, j, 1) + 1), c_double) + ef1 = cmplx(qp%eb_mov(idx_f(qp%ncomps, qp%node, & + get_me_iersp_sys(qp%zone_me, i) + p, 0) + 1), & + qp%eb_mov(idx_f(qp%ncomps, qp%node, & + get_me_iersp_sys(qp%zone_me, i) + p, 1) + 1), c_double) + ef2 = cmplx(qp%eb_mov(idx_f(qp%ncomps, qp%node, & + get_me_iersp_sys(qp%zone_me, j) + n2 + s, 0) + 1), & + qp%eb_mov(idx_f(qp%ncomps, qp%node, & + get_me_iersp_sys(qp%zone_me, j) + n2 + s, 1) + 1), c_double) + kf = kf + coeff*km*conjg(ef1)*ef2 + end do + end do + end do + end do + end do + end do + qp%kin_flux(idx_3(qp%dimx, spec, type_, qp%node) + 1) = real(fac*ii*kf, c_double)*qp%vol_fac*qp%r + end do + end do + + do type_ = 0, 1 + qp%kin_flux(idx_3(qp%dimx, 2, type_, qp%node) + 1) = & + qp%kin_flux(idx_3(qp%dimx, 0, type_, qp%node) + 1) + & + qp%kin_flux(idx_3(qp%dimx, 1, type_, qp%node) + 1) + end do + + do spec = 0, 2 + qp%kin_flux(idx_3(qp%dimx, spec, 2, qp%node) + 1) = & + qp%kin_flux(idx_3(qp%dimx, spec, 1, qp%node) + 1) - & + qp%kin_flux(idx_3(qp%dimx, spec, 0, qp%node) + 1) + end do + + qp%flag_computed(kin_flux_q) = .true. + end subroutine calc_kinetic_flux + + subroutine save_kinetic_flux(qp) + type(flre_quants_t), intent(in) :: qp + character(len=1) :: sort(0:2) + integer(c_int) :: spec, type_ + + sort = ['i', 'e', 't'] + + do spec = 0, 2 + do type_ = 0, 2 + call save_arr(qp%dimx, qp%x, qp%kin_flux(idx_3(qp%dimx, spec, type_, 0) + 1:), & + trim(qp%path2linear)//'zone_'//trim(itoa(qp%zone_index))// & + '_kin_flux_'//trim(itoa(type_))//'_'//sort(spec)//'.dat') + end do + end do + end subroutine save_kinetic_flux + + !================================================================== + ! poynting flux, total flux + !================================================================== + + subroutine calc_poynting_flux(qp) + type(flre_quants_t), intent(inout) :: qp + complex(c_double) :: es, ep, bs, bp_ + + es = cmplx(qp%eb_mov(idx_f(qp%ncomps, qp%node, get_me_iersp_sys(qp%zone_me, 1), 0) + 1), & + qp%eb_mov(idx_f(qp%ncomps, qp%node, get_me_iersp_sys(qp%zone_me, 1), 1) + 1), c_double) + ep = cmplx(qp%eb_mov(idx_f(qp%ncomps, qp%node, get_me_iersp_sys(qp%zone_me, 2), 0) + 1), & + qp%eb_mov(idx_f(qp%ncomps, qp%node, get_me_iersp_sys(qp%zone_me, 2), 1) + 1), c_double) + bs = cmplx(qp%eb_mov(idx_f(qp%ncomps, qp%node, get_me_ibrsp_sys(qp%zone_me, 1), 0) + 1), & + qp%eb_mov(idx_f(qp%ncomps, qp%node, get_me_ibrsp_sys(qp%zone_me, 1), 1) + 1), c_double) + bp_ = cmplx(qp%eb_mov(idx_f(qp%ncomps, qp%node, get_me_ibrsp_sys(qp%zone_me, 2), 0) + 1), & + qp%eb_mov(idx_f(qp%ncomps, qp%node, get_me_ibrsp_sys(qp%zone_me, 2), 1) + 1), c_double) + + qp%poy_flux(qp%node + 1) = qp%vol_fac*qp%r*cspeed/(4.0d0*pi)*0.5d0* & + real(conjg(es)*bp_ - conjg(ep)*bs, c_double) + + qp%flag_computed(poy_flux_q) = .true. + end subroutine calc_poynting_flux + + subroutine save_poynting_flux(qp) + type(flre_quants_t), intent(in) :: qp + + call save_arr(qp%dimx, qp%x, qp%poy_flux, & + trim(qp%path2linear)//'zone_'//trim(itoa(qp%zone_index))//'_poy_flux.dat') + end subroutine save_poynting_flux + + subroutine calc_total_flux(qp) + type(flre_quants_t), intent(inout) :: qp + + if (.not. (qp%flag_computed(kin_flux_q) .and. qp%flag_computed(poy_flux_q))) return + + qp%tot_flux(qp%node + 1) = qp%poy_flux(qp%node + 1) + qp%kin_flux(idx_3(qp%dimx, 2, 0, qp%node) + 1) + + qp%flag_computed(tot_flux_q) = .true. + end subroutine calc_total_flux + + subroutine save_total_flux(qp) + type(flre_quants_t), intent(in) :: qp + + call save_arr(qp%dimx, qp%x, qp%tot_flux, & + trim(qp%path2linear)//'zone_'//trim(itoa(qp%zone_index))//'_tot_flux.dat') + end subroutine save_total_flux + + subroutine calculate_field_profiles_poy_test(qp) + type(flre_quants_t), intent(inout) :: qp + integer(c_intptr_t) :: sidpf + real(c_double), allocatable :: spf(:), err(:) + real(c_double) :: divpfd(1), avrg_err, max_err + integer(c_int) :: k, ierr + + if (.not. (qp%flag_computed(abs_power_dens_q) .and. qp%flag_computed(poy_flux_q))) return + + allocate (spf(0:(qp%n_spline + 1)*qp%dimx - 1)) + call spline_alloc_c(qp%n_spline, 1, qp%dimx, qp%x, spf, sidpf) + call spline_calc_c(sidpf, qp%poy_flux, 0, 0, c_null_ptr, ierr) + + allocate (err(0:qp%dimx - 1)) + + avrg_err = 0.0d0 + max_err = 0.0d0 + + do k = 0, qp%dimx - 2 + qp%node = k + qp%r = qp%x(k + 1) + + call spline_eval_d_c(sidpf, 1, qp%x(k + 1:k + 1), 1, 1, 0, 0, divpfd) + + divpfd(1) = divpfd(1)/(-qp%r*qp%vol_fac) + + err(k) = abs(divpfd(1) - (qp%abs_pow_dens(idx_2(qp%dimx, 2, 0, k) + 1) + qp%jae_arr(k + 1)))/ & + max(1.0d0, abs(divpfd(1))) + + if (err(k) > max_err) max_err = err(k) + + avrg_err = avrg_err + err(k) + end do + + avrg_err = avrg_err/(qp%dimx - 1) + + if (get_output_flag_additional_c() > 1) then + call save_arr(qp%dimx - 1, qp%x, err, & + trim(qp%path2linear)//'zone_'//trim(itoa(qp%zone_index))//'_poy_test_err.dat') + end if + + call spline_free_c(sidpf) + deallocate (spf) + deallocate (err) + end subroutine calculate_field_profiles_poy_test + + !================================================================== + ! current density splines, number density, lorentz torque + !================================================================== + + subroutine calc_splines_for_current_density(qp) + type(flre_quants_t), intent(inout) :: qp + integer(c_int) :: spec, part, ind, k, ierr + integer(c_int), parameter :: type_ = 0, comp = 0 + + if (get_output_flag_quants_c(current_dens_q) == 0) return + + do spec = 0, 2 + do part = 0, 1 + ind = qp%dimx*(part + 2*spec) + do k = 0, qp%dimx - 1 + qp%yarr(ind + k + 1) = qp%current_dens(idx_cd(qp%dimx, spec, type_, comp, part, k) + 1) + end do + end do + end do + + call spline_calc_c(qp%sidY, qp%yarr, 0, qp%ny - 1, c_null_ptr, ierr) + + qp%flagS = .true. + end subroutine calc_splines_for_current_density + + subroutine calc_number_density(qp) + type(flre_quants_t), intent(inout) :: qp + character(kind=c_char) :: flag_back_buf(1) + real(c_double) :: kvals(3), djr(2) + complex(c_double) :: j(0:2), dj, nd + integer(c_int) :: spec, i, imin, imax + + if (.not. qp%flagS) return + + flag_back_buf(1) = get_background_flag_back_c() + + call eval_and_set_background_parameters_spec_independent_c(qp%r, flag_back_buf, 1_c_int) + call eval_and_set_wave_parameters_c(qp%r, flag_back_buf, 1_c_int) + call get_wave_parameters_c(kvals) + + do spec = 0, 1 + do i = 0, 2 + j(i) = cmplx(qp%current_dens(idx_cd(qp%dimx, spec, 0, i, 0, qp%node) + 1), & + qp%current_dens(idx_cd(qp%dimx, spec, 0, i, 1, qp%node) + 1), c_double) + end do + + imin = 2*spec + imax = imin + 1 + + call spline_eval_d_c(qp%sidY, 1, qp%x(qp%node + 1:qp%node + 1), 1, 1, imin, imax, djr) + + dj = cmplx(djr(1), djr(2), c_double) + + nd = -ii/qp%wd_omov/get_background_charge_c(spec)* & + (j(0)/qp%r + dj + ii*(kvals(2)*j(1) + kvals(3)*j(2))) + + qp%number_dens(idx_nd(qp%dimx, spec, 0, qp%node) + 1) = real(nd, c_double) + qp%number_dens(idx_nd(qp%dimx, spec, 1, qp%node) + 1) = aimag(nd) + end do + + qp%number_dens(idx_nd(qp%dimx, 2, 0, qp%node) + 1) = & + qp%number_dens(idx_nd(qp%dimx, 0, 0, qp%node) + 1)*(get_background_charge_c(0)/echarge) + & + qp%number_dens(idx_nd(qp%dimx, 1, 0, qp%node) + 1)*(get_background_charge_c(1)/echarge) + qp%number_dens(idx_nd(qp%dimx, 2, 1, qp%node) + 1) = & + qp%number_dens(idx_nd(qp%dimx, 0, 1, qp%node) + 1)*(get_background_charge_c(0)/echarge) + & + qp%number_dens(idx_nd(qp%dimx, 1, 1, qp%node) + 1)*(get_background_charge_c(1)/echarge) + + qp%flag_computed(number_dens_q) = .true. + end subroutine calc_number_density + + subroutine save_number_density(qp) + type(flre_quants_t), intent(in) :: qp + character(len=1) :: sort(0:2) + integer(c_int) :: spec + + sort = ['i', 'e', 't'] + + do spec = 0, 2 + call save_arr(qp%dimx, qp%x, qp%number_dens(idx_nd(qp%dimx, spec, 0, 0) + 1:), & + trim(qp%path2linear)//'zone_'//trim(itoa(qp%zone_index))//'_density_re_'//sort(spec)//'.dat') + end do + end subroutine save_number_density + + subroutine calc_lorentz_torque_density(qp) + type(flre_quants_t), intent(inout) :: qp + real(c_double) :: h(3) + character(kind=c_char) :: flag_back_buf(1) + complex(c_double) :: j_rsp(0:2), e_rsp(0:2), b_rsp(0:2) + complex(c_double) :: j_cyl(0:2), e_cyl(0:2), bc_cyl(0:2), jxbc(0:2) + complex(c_double) :: nd + integer(c_int) :: spec, i + + if (.not. qp%flag_computed(number_dens_q)) return + + flag_back_buf(1) = get_background_flag_back_c() + call eval_and_set_background_parameters_spec_independent_c(qp%r, flag_back_buf, 1_c_int) + call get_magnetic_field_parameters_c(h) + + do spec = 0, 1 + do i = 0, 2 + j_rsp(i) = cmplx(qp%current_dens(idx_cd(qp%dimx, spec, 0, i, 0, qp%node) + 1), & + qp%current_dens(idx_cd(qp%dimx, spec, 0, i, 1, qp%node) + 1), c_double) + e_rsp(i) = cmplx(qp%eb_mov(idx_f(qp%ncomps, qp%node, get_me_iersp_sys(qp%zone_me, i), 0) + 1), & + qp%eb_mov(idx_f(qp%ncomps, qp%node, get_me_iersp_sys(qp%zone_me, i), 1) + 1), c_double) + b_rsp(i) = cmplx(qp%eb_mov(idx_f(qp%ncomps, qp%node, get_me_ibrsp_sys(qp%zone_me, i), 0) + 1), & + qp%eb_mov(idx_f(qp%ncomps, qp%node, get_me_ibrsp_sys(qp%zone_me, i), 1) + 1), c_double) + end do + + j_cyl(0) = j_rsp(0) + j_cyl(1) = h(3)*j_rsp(1) + h(2)*j_rsp(2) + j_cyl(2) = h(3)*j_rsp(2) - h(2)*j_rsp(1) + + e_cyl(0) = e_rsp(0) + e_cyl(1) = h(3)*e_rsp(1) + h(2)*e_rsp(2) + e_cyl(2) = h(3)*e_rsp(2) - h(2)*e_rsp(1) + + bc_cyl(0) = conjg(b_rsp(0)) + bc_cyl(1) = conjg(h(3)*b_rsp(1) + h(2)*b_rsp(2)) + bc_cyl(2) = conjg(h(3)*b_rsp(2) - h(2)*b_rsp(1)) + + call vec_product_3d(j_cyl, bc_cyl, jxbc) + + nd = cmplx(qp%number_dens(idx_nd(qp%dimx, spec, 0, qp%node) + 1), & + qp%number_dens(idx_nd(qp%dimx, spec, 1, qp%node) + 1), c_double) + + do i = 0, 2 + qp%lor_torque_dens(idx_3(qp%dimx, spec, i, qp%node) + 1) = & + 0.5d0*real(get_background_charge_c(spec)*nd*conjg(e_cyl(i)) + & + echarge/cspeed*jxbc(i), c_double) + end do + + qp%lor_torque_dens(idx_3(qp%dimx, spec, 1, qp%node) + 1) = & + qp%lor_torque_dens(idx_3(qp%dimx, spec, 1, qp%node) + 1)*qp%r + qp%lor_torque_dens(idx_3(qp%dimx, spec, 2, qp%node) + 1) = & + qp%lor_torque_dens(idx_3(qp%dimx, spec, 2, qp%node) + 1)*get_background_rtor_c() + end do + + do i = 0, 2 + qp%lor_torque_dens(idx_3(qp%dimx, 2, i, qp%node) + 1) = & + qp%lor_torque_dens(idx_3(qp%dimx, 0, i, qp%node) + 1) + & + qp%lor_torque_dens(idx_3(qp%dimx, 1, i, qp%node) + 1) + end do + + qp%flag_computed(lor_torque_dens_q) = .true. + end subroutine calc_lorentz_torque_density + + subroutine calc_lorentz_torque_on_cylinder(qp) + type(flre_quants_t), intent(inout) :: qp + integer(c_int) :: spec, i + real(c_double) :: factor + + if (get_output_flag_quants_c(lor_torque_dens_q) == 0) return + + do spec = 0, 2 + do i = 0, 2 + if (i == 0) then + factor = 0.0d0 + else + factor = qp%vol_fac + end if + call integrate_over_cylinder(qp%dimx, qp%x, qp%lor_torque_dens(idx_3(qp%dimx, spec, i, 0) + 1:), & + factor, qp%lor_torque_int(idx_3(qp%dimx, spec, i, 0) + 1:)) + end do + end do + end subroutine calc_lorentz_torque_on_cylinder + + subroutine save_lorentz_torque(qp) + type(flre_quants_t), intent(in) :: qp + character(len=1) :: sort(0:2), comp(0:2) + integer(c_int) :: spec, i + + sort = ['i', 'e', 't'] + comp = ['r', 't', 'z'] + + do spec = 0, 2 + do i = 0, 2 + call save_arr(qp%dimx, qp%x, qp%lor_torque_dens(idx_3(qp%dimx, spec, i, 0) + 1:), & + trim(qp%path2linear)//'zone_'//trim(itoa(qp%zone_index))// & + '_torque_dens_'//comp(i)//'_'//sort(spec)//'.dat') + call save_arr(qp%dimx, qp%x, qp%lor_torque_int(idx_3(qp%dimx, spec, i, 0) + 1:), & + trim(qp%path2linear)//'zone_'//trim(itoa(qp%zone_index))// & + '_torque_int_'//comp(i)//'_'//sort(spec)//'.dat') + end do + end do + end subroutine save_lorentz_torque + + !================================================================== + ! helpers + !================================================================== + + subroutine vec_product_3d(a, b, res) + complex(c_double), intent(in) :: a(0:2), b(0:2) + complex(c_double), intent(out) :: res(0:2) + res(0) = a(1)*b(2) - a(2)*b(1) + res(1) = -(a(0)*b(2) - a(2)*b(0)) + res(2) = a(0)*b(1) - a(1)*b(0) + end subroutine vec_product_3d + + subroutine integrate_over_cylinder(dim, x, q, vol_fac, qi) + integer(c_int), intent(in) :: dim + real(c_double), intent(in) :: x(*), q(*), vol_fac + real(c_double), intent(out) :: qi(*) + integer(c_int) :: i + + qi(1) = 0.0d0 + do i = 2, dim + qi(i) = qi(i - 1) + vol_fac*0.5d0*(x(i) - x(i - 1))*(x(i - 1)*q(i - 1) + x(i)*q(i)) + end do + end subroutine integrate_over_cylinder + + !================================================================== + ! lab-frame / cylindrical-system current density transform + !================================================================== + + subroutine flre_quants_transform_quants_to_lab_cyl_frame(handle) & + bind(C, name="flre_quants_transform_quants_to_lab_cyl_frame_") + integer(c_intptr_t), value :: handle + type(flre_quants_t), pointer :: qp + real(c_double), allocatable :: cd(:) + + call handle_to_qp(handle, qp) + + if (get_output_flag_quants_c(current_dens_q) > 0) then + call eval_current_dens_in_lab_frame(qp, qp%cdlab) + end if + + if (get_output_flag_quants_c(current_dens_q) > 1) then + allocate (cd(0:2*3*2*3*qp%dimx - 1)) + + call eval_current_dens_in_lab_frame(qp, cd) + call save_current_density_ext(qp, cd, 'lab', 'rsp') + + call eval_current_dens_in_cyl_sys(qp, cd) + call save_current_density_ext(qp, cd, 'lab', 'rtz') + + deallocate (cd) + end if + end subroutine flre_quants_transform_quants_to_lab_cyl_frame + + subroutine eval_current_dens_in_lab_frame(qp, cd) + type(flre_quants_t), intent(in) :: qp + real(c_double), intent(inout) :: cd(0:) + complex(c_double) :: jj + real(c_double) :: htz(2), vel(0:2) + integer(c_int) :: k, type_, i, spec + + do k = 0, qp%dimx - 1 + call eval_hthz_c(qp%x(k + 1), 0, 0, qp%zone_bp, htz) + + vel(0) = 0.0d0 + vel(1) = -htz(1)*get_background_v_gal_sys_c() + vel(2) = htz(2)*get_background_v_gal_sys_c() + + do type_ = 0, 1 + do i = 0, 2 + do spec = 0, 1 + jj = cmplx(qp%current_dens(idx_cd(qp%dimx, spec, type_, i, 0, k) + 1), & + qp%current_dens(idx_cd(qp%dimx, spec, type_, i, 1, k) + 1), c_double) + & + get_background_charge_c(spec)*vel(i)* & + cmplx(qp%number_dens(idx_nd(qp%dimx, spec, 0, k) + 1), & + qp%number_dens(idx_nd(qp%dimx, spec, 1, k) + 1), c_double) + + cd(idx_cd(qp%dimx, spec, type_, i, 0, k)) = real(jj, c_double) + cd(idx_cd(qp%dimx, spec, type_, i, 1, k)) = aimag(jj) + end do + cd(idx_cd(qp%dimx, 2, type_, i, 0, k)) = cd(idx_cd(qp%dimx, 0, type_, i, 0, k)) + & + cd(idx_cd(qp%dimx, 1, type_, i, 0, k)) + cd(idx_cd(qp%dimx, 2, type_, i, 1, k)) = cd(idx_cd(qp%dimx, 0, type_, i, 1, k)) + & + cd(idx_cd(qp%dimx, 1, type_, i, 1, k)) + end do + end do + end do + end subroutine eval_current_dens_in_lab_frame + + subroutine eval_current_dens_in_cyl_sys(qp, cd) + type(flre_quants_t), intent(in) :: qp + real(c_double), intent(inout) :: cd(0:) + complex(c_double) :: jrsp(0:2), jcyl(0:2) + real(c_double) :: htz(2) + integer(c_int) :: k, type_, spec, i + + do k = 0, qp%dimx - 1 + call eval_hthz_c(qp%x(k + 1), 0, 0, qp%zone_bp, htz) + + do type_ = 0, 1 + do spec = 0, 2 + do i = 0, 2 + jrsp(i) = cmplx(cd(idx_cd(qp%dimx, spec, type_, i, 0, k)), & + cd(idx_cd(qp%dimx, spec, type_, i, 1, k)), c_double) + end do + + jcyl(0) = jrsp(0) + jcyl(1) = htz(2)*jrsp(1) + htz(1)*jrsp(2) + jcyl(2) = -htz(1)*jrsp(1) + htz(2)*jrsp(2) + + do i = 0, 2 + cd(idx_cd(qp%dimx, spec, type_, i, 0, k)) = real(jcyl(i), c_double) + cd(idx_cd(qp%dimx, spec, type_, i, 1, k)) = aimag(jcyl(i)) + end do + end do + end do + end do + end subroutine eval_current_dens_in_cyl_sys + + subroutine save_current_density_ext(qp, cd, frame, comp_set) + type(flre_quants_t), intent(in) :: qp + real(c_double), intent(in) :: cd(0:) + character(len=*), intent(in) :: frame + character(len=3), intent(in) :: comp_set + character(len=1) :: sort(0:2) + integer(c_int) :: spec, type_, i + + sort = ['i', 'e', 't'] + + do spec = 0, 2 + do type_ = 0, 1 + do i = 0, 2 + call save_arr(qp%dimx, qp%x, cd(idx_cd(qp%dimx, spec, type_, i, 0, 0):), & + trim(qp%path2linear)//'zone_'//trim(itoa(qp%zone_index))// & + '_current_dens_'//comp_set(i + 1:i + 1)//'_'//trim(itoa(type_))// & + '_'//sort(spec)//'_'//trim(frame)//'.dat') + end do + end do + end do + end subroutine save_current_density_ext + + !================================================================== + ! interpolation entry points (called externally from flre_zone.cpp) + !================================================================== + + subroutine flre_quants_interp_diss_power_density(handle, x, type_, spec, dpd) & + bind(C, name="flre_quants_interp_diss_power_density_") + integer(c_intptr_t), value :: handle + real(c_double), value :: x + integer(c_int), value :: type_, spec + real(c_double), intent(out) :: dpd(1) + type(flre_quants_t), pointer :: qp + integer(c_int) :: ind, deg + + call handle_to_qp(handle, qp) + + deg = 5 + ind = qp%dimx/2 + + call eval_neville_polynom(qp%dimx, qp%x, qp%diss_pow_dens(idx_3(qp%dimx, spec, type_, 0) + 1:), & + deg, x, 0, 0, ind, dpd) + end subroutine flre_quants_interp_diss_power_density + + subroutine flre_quants_interp_current_density(handle, x, type_, spec, comp, jout) & + bind(C, name="flre_quants_interp_current_density_") + integer(c_intptr_t), value :: handle + real(c_double), value :: x + integer(c_int), value :: type_, spec, comp + real(c_double), intent(out) :: jout(2) + type(flre_quants_t), pointer :: qp + integer(c_int) :: ind, deg + + call handle_to_qp(handle, qp) + + deg = 5 + ind = qp%dimx/2 + + call eval_neville_polynom(qp%dimx, qp%x, qp%cdlab(idx_cd(qp%dimx, spec, type_, comp, 0, 0) + 1:), & + deg, x, 0, 0, ind, jout(1)) + ind = qp%dimx/2 + call eval_neville_polynom(qp%dimx, qp%x, qp%cdlab(idx_cd(qp%dimx, spec, type_, comp, 1, 0) + 1:), & + deg, x, 0, 0, ind, jout(2)) + end subroutine flre_quants_interp_current_density + + !================================================================== + ! absorbed energy from antenna current (work of E field on Ja) + !================================================================== + + subroutine flre_quants_calculate_jae(handle) bind(C, name="flre_quants_calculate_jae_") + integer(c_intptr_t), value :: handle + type(flre_quants_t), pointer :: qp + integer(c_int) :: k + + call handle_to_qp(handle, qp) + + do k = 0, qp%dimx - 1 + qp%jae_arr(k + 1) = 0.0d0 + qp%jaei_arr(k + 1) = 0.0d0 + end do + + if (get_antenna_wa_c() == 0.0d0) then + call calculate_jae_delta(qp) + else + call calculate_jae_distributed(qp) + end if + end subroutine flre_quants_calculate_jae + + subroutine calculate_jae_delta(qp) + type(flre_quants_t), intent(inout) :: qp + integer(c_int) :: ia + real(c_double) :: jsurf(4), jsurft(4), antenna_ra + complex(c_double) :: ja(0:1), ef(0:1) + integer(c_int) :: iersp_sys(0:2) + real(c_double) :: es_re, es_im, ep_re, ep_im + + if (qp%bc1 == boundary_antenna) then + ia = 0 + else if (qp%bc2 == boundary_antenna) then + ia = qp%dimx - 1 + else + return + end if + + call current_density_c(jsurf) + antenna_ra = get_antenna_ra_c() + call cyl2rsp_c(antenna_ra, jsurf, jsurf(3:), jsurft, jsurft(3:)) + + ja(0) = cmplx(jsurft(1), jsurft(2), c_double) + ja(1) = cmplx(jsurft(3), jsurft(4), c_double) + + iersp_sys(0) = get_me_iersp_sys(qp%zone_me, 0) + iersp_sys(1) = get_me_iersp_sys(qp%zone_me, 1) + iersp_sys(2) = get_me_iersp_sys(qp%zone_me, 2) + + es_re = qp%eb_mov(idx_f(qp%ncomps, ia, iersp_sys(1), 0) + 1) + es_im = qp%eb_mov(idx_f(qp%ncomps, ia, iersp_sys(1), 1) + 1) + ep_re = qp%eb_mov(idx_f(qp%ncomps, ia, iersp_sys(2), 0) + 1) + ep_im = qp%eb_mov(idx_f(qp%ncomps, ia, iersp_sys(2), 1) + 1) + + ef(0) = cmplx(es_re, es_im, c_double) + ef(1) = cmplx(ep_re, ep_im, c_double) + + qp%jae = 0.5d0*qp%vol_fac*qp%x(ia + 1)*real(ja(0)*conjg(ef(0)) + ja(1)*conjg(ef(1)), c_double) + + if (get_output_flag_emfield_c() > 1) then + call save_arr(1, qp%x(ia + 1:ia + 1), [qp%jae], & + trim(qp%path2linear)//'zone_'//trim(itoa(qp%zone_index))//'_JaE.dat') + end if + end subroutine calculate_jae_delta + + subroutine calculate_jae_distributed(qp) + type(flre_quants_t), intent(inout) :: qp + real(c_double) :: ja_rsp(4) + complex(c_double) :: ja(0:1), ef(0:1) + integer(c_int) :: iersp_sys(0:2) + integer(c_int) :: k + real(c_double) :: es_re, es_im, ep_re, ep_im + + iersp_sys(0) = get_me_iersp_sys(qp%zone_me, 0) + iersp_sys(1) = get_me_iersp_sys(qp%zone_me, 1) + iersp_sys(2) = get_me_iersp_sys(qp%zone_me, 2) + + do k = 0, qp%dimx - 1 + call calc_current_density_r_s_p_c(qp%x(k + 1), ja_rsp) + + ja(0) = cmplx(ja_rsp(1), ja_rsp(2), c_double) + ja(1) = cmplx(ja_rsp(3), ja_rsp(4), c_double) + + es_re = qp%eb_mov(idx_f(qp%ncomps, k, iersp_sys(1), 0) + 1) + es_im = qp%eb_mov(idx_f(qp%ncomps, k, iersp_sys(1), 1) + 1) + ep_re = qp%eb_mov(idx_f(qp%ncomps, k, iersp_sys(2), 0) + 1) + ep_im = qp%eb_mov(idx_f(qp%ncomps, k, iersp_sys(2), 1) + 1) + + ef(0) = cmplx(es_re, es_im, c_double) + ef(1) = cmplx(ep_re, ep_im, c_double) + + qp%jae_arr(k + 1) = 0.5d0*real(ja(0)*conjg(ef(0)) + ja(1)*conjg(ef(1)), c_double) + end do + + call integrate_over_cylinder(qp%dimx, qp%x, qp%jae_arr, qp%vol_fac, qp%jaei_arr) + + qp%jae = qp%jaei_arr(qp%dimx) + + if (get_output_flag_emfield_c() > 1) then + call save_arr(1, qp%x(qp%dimx:qp%dimx), [qp%jae], & + trim(qp%path2linear)//'zone_'//trim(itoa(qp%zone_index))//'_JaE.dat') + call save_arr(qp%dimx, qp%x, qp%jae_arr, & + trim(qp%path2linear)//'zone_'//trim(itoa(qp%zone_index))//'_jaE_dens.dat') + call save_arr(qp%dimx, qp%x, qp%jaei_arr, & + trim(qp%path2linear)//'zone_'//trim(itoa(qp%zone_index))//'_jaE_int.dat') + end if + end subroutine calculate_jae_distributed + + !================================================================== + ! handle plumbing + !================================================================== + + subroutine handle_to_qp(handle, qp) + integer(c_intptr_t), value :: handle + type(flre_quants_t), pointer, intent(out) :: qp + type(c_ptr) :: ccp + ccp = transfer(handle, ccp) + call c_f_pointer(ccp, qp) + end subroutine handle_to_qp + + subroutine read_c_string(cp_, out) + type(c_ptr), value :: cp_ + character(len=*), intent(out) :: out + character(kind=c_char), pointer :: chars(:) + integer :: i + + call c_f_pointer(cp_, chars, [len(out)]) + out = '' + do i = 1, len(out) + if (chars(i) == c_null_char) exit + out(i:i) = chars(i) + end do + end subroutine read_c_string + +end module kilca_flre_quants_m diff --git a/KiLCA/flre/quants/transf_quants.cpp b/KiLCA/flre/quants/transf_quants.cpp deleted file mode 100644 index 8c284e5a..00000000 --- a/KiLCA/flre/quants/transf_quants.cpp +++ /dev/null @@ -1,541 +0,0 @@ -/*! \file transf_quants.cpp - \brief The implementation of functions declared in transf_quants.h. -*/ - -#include "transf_quants.h" -#include "quants_profs.h" -#include "constants.h" -#include "inout.h" -#include "eval_back.h" - -/*******************************************************************/ - -void transform_quants_to_lab_sys (const quants_profiles *qp) -{ -//transforms all relevant quants to the laboratory frame: - -//fields: -double *field = new double[2*6*(qp->fp->dimx)]; -eval_and_save_EB_fields_in_lab_frame (qp, field); - -delete [] field; - -//current density: -if (qp->sd->os->flag_quants[qp->CURRENT_DENS] == 2) -{ - double *cd = new double[3*2*3*2*(qp->dimx)]; - - char lframe[] = "lab"; - char cylcomp[] = "rtz"; - char rspcomp[] = "rsp"; - - eval_current_dens_in_lab_frame (qp, cd); - save_current_density (qp, cd, (const char *)lframe, (const char *)rspcomp); - - eval_current_dens_in_cyl_sys (qp, cd); - save_current_density (qp, cd, (const char *)lframe, (const char *)cylcomp); - - delete [] cd; -} -} - -/*******************************************************************/ - -void eval_current_dens_in_lab_frame (const quants_profiles *qp, double *cd) -{ -//transforms current density to lab frame -//current density for each r value: {{{re,im},comp={r,s,p},type={0,1},spec={i,e,t}} -typedef double curr_dens[3][2][3][2][qp->dimx]; -uintptr_t ind_cd = (qp->dimx)*(qp->offset[qp->ind[qp->CURRENT_DENS]]); -curr_dens &CD = *((curr_dens *)(qp->qloc+ind_cd)); - -//number density each r value: //{{re,im},spec={i,e,t}} -typedef double number_dens[3][2][qp->dimx]; -uintptr_t ind_nd = (qp->dimx)*(qp->offset[qp->ind[qp->NUMBER_DENS]]); //index of number density -number_dens &ND = *((number_dens *)(qp->qloc+ind_nd)); //address of number density - -curr_dens &cude = *((curr_dens *)(cd)); - -complex J; - -double htz[2]; -double vel[3]; - -for (int k=0; kdimx; k++) //over r grid -{ - eval_hthz (qp->x[k], 0, 0, qp->bp, htz); - - vel[0] = 0.0; //r component - vel[1] = - htz[0]*(qp->bp->V_gal_sys); //s component - vel[2] = htz[1]*(qp->bp->V_gal_sys); //p component - - for (int type=0; type<2; type++) //over current types - { - for (int i=0; i<3; i++) //over current density components - { - for (int spec=0; spec<2; spec++) //over species (i,e) - { - //j = j' + e n' V - J = (CD[spec][type][i][0][k] + I*CD[spec][type][i][1][k]) + - (qp->bp->charge[spec])*(vel[i]) * - (ND[spec][0][k] +I*ND[spec][1][k]); - - cude[spec][type][i][0][k] = real(J); - cude[spec][type][i][1][k] = imag(J); - } - //total current density: - cude[2][type][i][0][k] = cude[0][type][i][0][k] + cude[1][type][i][0][k]; - cude[2][type][i][1][k] = cude[0][type][i][1][k] + cude[1][type][i][1][k]; - } - } -} -} - -/*******************************************************************/ - -void eval_current_dens_in_cyl_sys (const quants_profiles *qp, double *cd) -{ -//transforms current density to cylindrical system and overwrite it to cd -//current density for each r value: {{{re,im},comp={r,s,p},type={0,1},spec={i,e,t}} -typedef double curr_dens[3][2][3][2][qp->dimx]; -curr_dens &cude = *((curr_dens *)(cd)); - -complex Jrsp[3], Jcyl[3]; - -double htz[2]; - -for (int k=0; kdimx; k++) //over r grid -{ - eval_hthz (qp->x[k], 0, 0, qp->bp, htz); - - for (int type=0; type<2; type++) //over current types - { - for (int spec=0; spec<3; spec++) //over species (i,e,t) - { - for (int i=0; i<3; i++) //over current density components - { - Jrsp[i] = cude[spec][type][i][0][k] + I*cude[spec][type][i][1][k]; - } - - //transform to cylyndrical system: - Jcyl[0] = Jrsp[0]; - Jcyl[1] = htz[1]*Jrsp[1] + htz[0]*Jrsp[2]; - Jcyl[2] = - htz[0]*Jrsp[1] + htz[1]*Jrsp[2]; - - for (int i=0; i<3; i++) //over current density components - { - cude[spec][type][i][0][k] = real(Jcyl[i]); - cude[spec][type][i][1][k] = imag(Jcyl[i]); - } - } - } -} -} - -/*******************************************************************/ - -void save_current_density (const quants_profiles *qp, double *cd, const char *frame, const char *comp) -{ -char *filename = new char[1024]; - -char sort[3] = {'i','e','t'}; - -FILE *outfile; - -//current density for each r value: {{{re,im},comp={r,s,p},type={0,1},spec={i,e,t}} -typedef double curr_dens[3][2][3][2][qp->dimx]; -curr_dens &cude = *((curr_dens *)(cd)); - -for (int spec=0; spec<3; spec++) //over species -{ - for (int type=0; type<2; type++) //over current types - { - for (int i=0; i<3; i++) //over current density components - { - //file name: - sprintf (filename, "%s%s_dens_%c_%d_%c_%s.dat", qp->path2linear, qp->name[qp->CURRENT_DENS], comp[i], type, sort[spec], frame); - - if (!(outfile = fopen (filename, "w"))) - { - fprintf (stderr, "\nFailed to open file %s\a\n", filename); - } - - for (int k=0; kdimx; k++) //over r grid - { - fprintf (outfile, "%24.16le\t%24.16le\t%24.16le\n", - qp->x[k], cude[spec][type][i][0][k], cude[spec][type][i][1][k]); - } - fclose (outfile); - } - } -} - -delete [] filename; - -fprintf (stdout, "\n%s in %s frame in %s coordinates is saved.", qp->name[qp->CURRENT_DENS], frame, comp); -} - -/*******************************************************************/ - -void eval_and_save_EB_fields_in_lab_frame (const quants_profiles *qp, double *field) -{ -//transforms fields to lab frame -//EM field profiles: {0...dimx}, {0...num_vars}, {re,im} -typedef double em_field_data[qp->fp->dimx][qp->fp->dimEB][2]; -em_field_data &F = *((em_field_data *)qp->fp->EB); - -typedef double eb_field[6][2][qp->fp->dimx]; -eb_field &eb = *((eb_field *)field); - -double *fieldcm = new double[2*6*(qp->fp->dimx)]; //cyl mov -eb_field &ebcm = *((eb_field *)fieldcm); - -double *fieldcl = new double[2*6*(qp->fp->dimx)]; //cyl lab -eb_field &ebcl = *((eb_field *)fieldcl); - -complex Erspmov[3], Ecylmov[3], Ecyllab[3], Ersplab[3]; -complex Brspmov[3], Bcylmov[3], Bcyllab[3], Brsplab[3]; - -double htz[2]; - -for (int k=0; kfp->dimx; k++) //over r grid -{ - for (int i=0; i<3; i++) //over field rsp components - { - Erspmov[i] = F[k][qp->fp->iEB_sys[0][i]][0] + F[k][qp->fp->iEB_sys[0][i]][1]*I; - Brspmov[i] = F[k][qp->fp->iEB_sys[1][i]][0] + F[k][qp->fp->iEB_sys[1][i]][1]*I; - } - - eval_hthz (qp->fp->x[k], 0, 0, qp->bp, htz); - - //transform to cylyndrical system: - Ecylmov[0] = Erspmov[0]; - Ecylmov[1] = htz[1]*Erspmov[1] + htz[0]*Erspmov[2]; - Ecylmov[2] = - htz[0]*Erspmov[1] + htz[1]*Erspmov[2]; - - Bcylmov[0] = Brspmov[0]; - Bcylmov[1] = htz[1]*Brspmov[1] + htz[0]*Brspmov[2]; - Bcylmov[2] = - htz[0]*Brspmov[1] + htz[1]*Brspmov[2]; - - //store: - for (int i=0; i<3; i++) - { - ebcm[i][0][k] = real (Ecylmov[i]); - ebcm[i][1][k] = imag (Ecylmov[i]); - ebcm[3+i][0][k] = real (Bcylmov[i]); - ebcm[3+i][1][k] = imag (Bcylmov[i]); - } - - //transform to laboratory frame: Landau II, p. 91 - //E' = E + 1/c V x B, B' = B - 1/c V x E - //E = E' - 1/c V x B', B = B' + 1/c V x E' - //V x A = e_r (-V A_th) + e_th (V A_r) + e_z (0); - Ecyllab[0] = Ecylmov[0] + (qp->bp->V_gal_sys)/c*Bcylmov[1]; - Ecyllab[1] = Ecylmov[1] - (qp->bp->V_gal_sys)/c*Bcylmov[0]; - Ecyllab[2] = Ecylmov[2]; - - Bcyllab[0] = Bcylmov[0] - (qp->bp->V_gal_sys)/c*Ecylmov[1]; - Bcyllab[1] = Bcylmov[1] + (qp->bp->V_gal_sys)/c*Ecylmov[0]; - Bcyllab[2] = Bcylmov[2]; - - //store: - for (int i=0; i<3; i++) - { - ebcl[i][0][k] = real (Ecyllab[i]); - ebcl[i][1][k] = imag (Ecyllab[i]); - ebcl[3+i][0][k] = real (Bcyllab[i]); - ebcl[3+i][1][k] = imag (Bcyllab[i]); - } - - //transform to rsp system: - Ersplab[0] = Ecyllab[0]; - Ersplab[1] = htz[1]*Ecyllab[1] - htz[0]*Ecyllab[2]; - Ersplab[2] = htz[0]*Ecyllab[1] + htz[1]*Ecyllab[2]; - - Brsplab[0] = Bcyllab[0]; - Brsplab[1] = htz[1]*Bcyllab[1] - htz[0]*Bcyllab[2]; - Brsplab[2] = htz[0]*Bcyllab[1] + htz[1]*Bcyllab[2]; - - //store: - for (int i=0; i<3; i++) - { - eb[i][0][k] = real (Ersplab[i]); - eb[i][1][k] = imag (Ersplab[i]); - eb[3+i][0][k] = real (Brsplab[i]); - eb[3+i][1][k] = imag (Brsplab[i]); - } -} - -char mframe[] = "mov"; -char lframe[] = "lab"; -char cylcomp[] = "rtz"; -char rspcomp[] = "rsp"; - -save_EB_fields (qp, fieldcm, (const char *)mframe, (const char *)cylcomp); -save_EB_fields (qp, fieldcl, (const char *)lframe, (const char *)cylcomp); -save_EB_fields (qp, field, (const char *)lframe, (const char *)rspcomp); - -delete [] fieldcm; -delete [] fieldcl; -} - -/*******************************************************************/ - -void save_EB_fields (const quants_profiles *qp, const double *fields, const char *frame, const char *comp) -{ -char *filename = new char[1024]; - -char field[2] = {'e','b'}; -FILE *outfile; - -typedef double eb_field[6][2][qp->fp->dimx]; -eb_field &eb = *((eb_field *)fields); - -for (int i=0; i<2; i++) //e, b -{ - for (int j=0; j<3; j++) //r,s,p - { - sprintf (filename, "%s%c%c_%s.dat", qp->path2linear, field[i], comp[j], frame); - if (!(outfile = fopen (filename, "w"))) - { - fprintf (stderr, "\nFailed to open file %s\a\n", filename); - } - - for (int k=0; kfp->dimx; k++) - { - fprintf (outfile, "%24.16le", qp->fp->x[k]); - fprintf (outfile, "\t%24.16le", eb[j+3*i][0][k]); - fprintf (outfile, "\t%24.16le", eb[j+3*i][1][k]); - fprintf (outfile, "\n"); - } - fclose (outfile); - } -} -fprintf (stdout, "\nE & B fields in %s frame in %s coordinates are saved.", frame, comp); -delete [] filename; -} - -/*******************************************************************/ - -void transform_EB_fields_to_mov_frame (const background *bp, int dim, double *x, double *field) -{ -//transforms fields to mov frame -//EM field profiles: {0...dimx}, {0...num_vars}, {re,im} -typedef double eb_field[6][2][dim]; -eb_field &eb = *((eb_field *)field); - -complex Erspmov[3], Ecylmov[3], Ecyllab[3], Ersplab[3]; -complex Brspmov[3], Bcylmov[3], Bcyllab[3], Brsplab[3]; - -double htz[2]; - -for (int k=0; kV_gal_sys)/c*Bcyllab[1]; - Ecylmov[1] = Ecyllab[1] + (bp->V_gal_sys)/c*Bcyllab[0]; - Ecylmov[2] = Ecyllab[2]; - - Bcylmov[0] = Bcyllab[0] + (bp->V_gal_sys)/c*Ecyllab[1]; - Bcylmov[1] = Bcyllab[1] - (bp->V_gal_sys)/c*Ecyllab[0]; - Bcylmov[2] = Bcyllab[2]; - - //transform to rsp system: - Erspmov[0] = Ecylmov[0]; - Erspmov[1] = htz[1]*Ecylmov[1] - htz[0]*Ecylmov[2]; - Erspmov[2] = htz[0]*Ecylmov[1] + htz[1]*Ecylmov[2]; - - Brspmov[0] = Bcylmov[0]; - Brspmov[1] = htz[1]*Bcylmov[1] - htz[0]*Bcylmov[2]; - Brspmov[2] = htz[0]*Bcylmov[1] + htz[1]*Bcylmov[2]; - - //store: - for (int i=0; i<3; i++) - { - eb[i][0][k] = real (Erspmov[i]); - eb[i][1][k] = imag (Erspmov[i]); - eb[3+i][0][k] = real (Brspmov[i]); - eb[3+i][1][k] = imag (Brspmov[i]); - } -} -} - -/*******************************************************************/ - -template void -calc_derive_of_func_product (int N, double *C, int n, const T1 *f, const T2 *g, T3 *fg) -{ -//N - max n index in C^k_n array -//C - binomial coefficients (C^k_n = C[n+k*(N+1)]) array -//n - order of the der, n<=N -//f - array of the f derivs -//g - array of the g derivs -//fg - the value of the fg deriv of n-th order - -*fg = 0; for (int k=0; k<=n; k++) *fg += C[n+k*(N+1)]*f[k]*g[n-k]; -} - -/*******************************************************************/ - -void transform_start_values_to_mov_frame (const field_profiles *fp, double r, double *Smat) -{ -int *dim_Ersp_state = (int *) fp->me->dim_Ersp_state; -int *iErsp_state = (int *) fp->me->iErsp_state; - -//max orders of the derivative for Er, Es, Ep: -int mo[3] = {dim_Ersp_state[0]-1, dim_Ersp_state[1]-1, dim_Ersp_state[2]-1}; - -//wave data: -int m = fp->wd->m; -double kz = (fp->wd->n)/(fp->bp->rtor); -complex omlab = fp->wd->omov + kz*(fp->bp->V_gal_sys); - -int ho = mo[2]; //max der order (2N-1); - -//binomial coefficients: -double *C = new double[(ho+1)*(ho+1)]; -binomial_coefficients (ho, C); - -double *htz = new double[2*(ho+1)]; -double *ht = htz, *hz = htz + ho + 1; - -eval_hthz (r, 0, ho, fp->bp, htz); //ht & hz derivs - -double *mor = new double[ho+1]; //(m/r) derivatives - -mor[0] = m/r; for (int o=1; o<=ho; o++) mor[o] = (-o/r)*mor[o-1]; - -double *ks = new double[ho+1]; -double *kp = new double[ho+1]; - -double htmor, hzmor; - -for (int o=0; o<=ho; o++) -{ - calc_derive_of_func_product (ho, C, o, ht, mor, &htmor); //ht*(m/r) derivatives - calc_derive_of_func_product (ho, C, o, hz, mor, &hzmor); //hz*(m/r) derivatives - - ks[o] = hzmor - ht[o]*kz; - kp[o] = htmor + hz[o]*kz; -} - -complex *Elab[3], *Emov[3]; //Er, Es, Ep - -for (int k=0; k<3; k++) -{ - Elab[k] = new complex[mo[k]+1]; - Emov[k] = new complex[mo[k]+1]; -} - -complex *Br = new complex[ho+1]; -complex *Ez = new complex[ho+1]; -complex *htBr = new complex[ho+1]; -complex *hzBr = new complex[ho+1]; - -complex kpEs, ksEp, hzEp, htEs; - -int Nfs = fp->sd->es->Nfs; -int Nwaves = fp->sd->es->Nwaves; - -double V = fp->bp->V_gal_sys; - -for (int j=0; jm; -double kz = (wd->n)/(sd->bs->rtor); - -double comega[2] = {real(wd->olab), imag(wd->olab)}; //lab frame - -double csigma[2] = {real(sigma), imag(sigma)}; //lab frame - -//makes homogenious radial grid: -double dr = (r2-r1)/(dim-1); - -for (int i=0; i -#include -#include -#include - -using namespace :: std; - -#include "zone.h" - -/*****************************************************************************/ - -/*! \class hmedium_zone - \brief The class represents properties and data of a plasma zone described by ideal MHD equations. -*/ -class hmedium_zone : public zone -{ -public: - complex sigma; //! Vacuum/homogeneous-medium zone, formerly the C++ hmedium_zone class +!> (hmedium_zone.{h,cpp}). Simplest concrete zone_t extension: a closed-form +!> basis (eval_basis_in_hom_media, pre-existing legacy Fortran), and no +!> dispersion/quantities support (those methods are no-ops or error stubs +!> in the oracle, preserved as-is). +module kilca_hmedium_zone_m + use, intrinsic :: iso_c_binding, only: c_int, c_intptr_t, c_double, c_char, c_ptr + use constants, only: dp + use kilca_wave_data_m, only: wave_data_t + use kilca_zone_m, only: zone_t, zone_register, zone_read, zone_print, skip_line, & + read_real_before_hash, read_int_before_hash, read_complex_before_hash + implicit none + private + + public :: hmedium_zone_t + public :: hmedium_zone_create + + type, extends(zone_t) :: hmedium_zone_t + complex(dp) :: sigma = (0, 0) + contains + procedure :: read_settings => hmedium_read_settings + procedure :: print_settings => hmedium_print_settings + procedure :: calc_basis_fields => hmedium_calc_basis_fields + procedure :: copy_E_and_B_fields => hmedium_copy_E_and_B_fields + procedure :: calc_final_fields => hmedium_calc_final_fields + procedure :: calc_dispersion => hmedium_calc_dispersion + procedure :: save_dispersion => hmedium_save_dispersion + procedure :: calc_all_quants => hmedium_calc_all_quants + procedure :: save_all_quants => hmedium_save_all_quants + procedure :: eval_diss_power_density => hmedium_eval_diss_power_density + procedure :: eval_current_density => hmedium_eval_current_density + end type hmedium_zone_t + + interface + subroutine eval_basis_in_hom_media(m, kz, omega, sigma, rval, EB) + import :: dp + integer, intent(in) :: m + real(dp), intent(in) :: kz + complex(dp), intent(in) :: omega, sigma + real(dp), intent(in) :: rval + complex(dp), intent(out) :: EB(6, 4) + end subroutine eval_basis_in_hom_media + + function get_background_rtor() bind(C, name="get_background_rtor_") result(rtor) + import :: c_double + real(c_double) :: rtor + end function get_background_rtor + end interface + +contains + + function hmedium_zone_create(sd_ptr, bp_ptr, wd_handle, path, index_p) & + result(handle) bind(C, name="hmedium_zone_create_") + integer(c_intptr_t), value :: sd_ptr, bp_ptr, wd_handle + character(kind=c_char), intent(in) :: path(*) + integer(c_int), value :: index_p + integer(c_intptr_t) :: handle + + type(hmedium_zone_t), pointer :: hz + class(zone_t), pointer :: zp + type(c_ptr) :: wd_cptr + + allocate (hz) + hz%bp = bp_ptr + hz%index = int(index_p) + hz%path = zone_c_string(path) + wd_cptr = transfer(wd_handle, wd_cptr) + call c_f_pointer_local(wd_cptr, hz%wd) + + zp => hz + handle = zone_register(zp) + end function hmedium_zone_create + + subroutine c_f_pointer_local(cptr, wd) + use, intrinsic :: iso_c_binding, only: c_f_pointer + type(c_ptr), intent(in) :: cptr + type(wave_data_t), pointer, intent(out) :: wd + call c_f_pointer(cptr, wd) + end subroutine c_f_pointer_local + + function zone_c_string(cstr) result(fstr) + use, intrinsic :: iso_c_binding, only: c_null_char + character(kind=c_char), intent(in) :: cstr(*) + character(len=1024) :: fstr + integer :: i + fstr = '' + i = 0 + do + if (cstr(i + 1) == c_null_char .or. i >= 1024) exit + fstr(i + 1:i + 1) = cstr(i + 1) + i = i + 1 + end do + end function zone_c_string + + subroutine hmedium_read_settings(self, file) + class(hmedium_zone_t), intent(inout) :: self + character(len=*), intent(in) :: file + integer :: unit, ios, k + + call zone_read(self, file) + + open (newunit=unit, file=trim(file), status='old', action='read', iostat=ios) + if (ios /= 0) then + write (*, '(a,a)') 'error: hmedium_zone: read_settings: failed to open file ', trim(file) + stop 1 + end if + + do k = 1, 8 + call skip_line(unit) + end do + + call skip_line(unit) + call read_complex_before_hash(unit, self%sigma) + call skip_line(unit) + + call skip_line(unit) + call read_int_before_hash(unit, self%max_dim) + call read_real_before_hash(unit, self%eps_rel) + call read_real_before_hash(unit, self%eps_abs) + call skip_line(unit) + + call skip_line(unit) + call read_int_before_hash(unit, self%deg) + call read_real_before_hash(unit, self%reps) + call read_real_before_hash(unit, self%aeps) + call read_real_before_hash(unit, self%step) + call skip_line(unit) + + call skip_line(unit) + call read_int_before_hash(unit, self%flag_debug) + call skip_line(unit) + + close (unit) + + self%Nwaves = 4 + self%Ncomps = 6 + + if (self%flag_debug /= 0) call self%print_settings() + end subroutine hmedium_read_settings + + subroutine hmedium_print_settings(self) + class(hmedium_zone_t), intent(in) :: self + call zone_print(self) + write (*, '(a,es16.8e3,a,es16.8e3,a)') 'medium conductivity: (', & + real(self%sigma, dp), ', ', aimag(self%sigma), ')' + end subroutine hmedium_print_settings + + subroutine hmedium_calc_basis_fields(self, flag) + class(hmedium_zone_t), intent(inout) :: self + integer, intent(in) :: flag + integer :: i, m + real(dp) :: kz, dr + + self%dim = self%max_dim + if (allocated(self%r)) deallocate (self%r) + allocate (self%r(self%dim)) + if (allocated(self%basis)) deallocate (self%basis) + allocate (self%basis(self%Ncomps, self%Nwaves, self%dim)) + + m = self%wd%m + kz = real(self%wd%n, dp)/get_background_rtor() + + dr = (self%r2 - self%r1)/(self%dim - 1) + + do i = 1, self%dim + self%r(i) = self%r1 + dr*(i - 1) + call eval_basis_in_hom_media(m, kz, self%wd%olab, self%sigma, self%r(i), self%basis(:, :, i)) + end do + + self%r(self%dim) = self%r2 + call eval_basis_in_hom_media(m, kz, self%wd%olab, self%sigma, self%r(self%dim), self%basis(:, :, self%dim)) + end subroutine hmedium_calc_basis_fields + + subroutine hmedium_copy_E_and_B_fields(self, EB_out) + class(hmedium_zone_t), intent(in) :: self + real(dp), intent(out) :: EB_out(*) + integer :: node, comp + + do node = 0, self%dim - 1 + do comp = 0, 5 + EB_out(2*(comp + 6*node) + 1) = real(self%EB(comp + 1, node + 1), dp) + EB_out(2*(comp + 6*node) + 2) = aimag(self%EB(comp + 1, node + 1)) + end do + end do + end subroutine hmedium_copy_E_and_B_fields + + subroutine hmedium_calc_final_fields(self) + class(hmedium_zone_t), intent(inout) :: self + end subroutine hmedium_calc_final_fields + + subroutine hmedium_calc_dispersion(self) + class(hmedium_zone_t), intent(inout) :: self + end subroutine hmedium_calc_dispersion + + subroutine hmedium_save_dispersion(self) + class(hmedium_zone_t), intent(inout) :: self + end subroutine hmedium_save_dispersion + + subroutine hmedium_calc_all_quants(self) + class(hmedium_zone_t), intent(inout) :: self + end subroutine hmedium_calc_all_quants + + subroutine hmedium_save_all_quants(self) + class(hmedium_zone_t), intent(inout) :: self + end subroutine hmedium_save_all_quants + + subroutine hmedium_eval_diss_power_density(self, x, ttype, spec, dpd) + class(hmedium_zone_t), intent(in) :: self + real(dp), intent(in) :: x + integer, intent(in) :: ttype, spec + real(dp), intent(out) :: dpd(*) + write (*, '(a)') 'error: eval_diss_power_density() is not implemented for the hmedium_zone' + end subroutine hmedium_eval_diss_power_density + + subroutine hmedium_eval_current_density(self, x, ttype, spec, comp, J) + class(hmedium_zone_t), intent(in) :: self + real(dp), intent(in) :: x + integer, intent(in) :: ttype, spec, comp + real(dp), intent(out) :: J(*) + J(1) = 0.0d0 + J(2) = 0.0d0 + end subroutine hmedium_eval_current_density + +end module kilca_hmedium_zone_m diff --git a/KiLCA/imhd/compressible_flow.cpp b/KiLCA/imhd/compressible_flow.cpp deleted file mode 100644 index c78c0e48..00000000 --- a/KiLCA/imhd/compressible_flow.cpp +++ /dev/null @@ -1,586 +0,0 @@ -/*! \file compressible_flow.cpp - \brief The definitions of functions declared in compressible_flow.h. -*/ - -#include -#include -#include -#include -#include -#include - -#include "fortnum.h" - -#include "constants.h" -#include "shared.h" -#include "eval_back.h" -#include "imhd_zone.h" -#include "compressible_flow.h" - -// GSL returned 0 (GSL_SUCCESS) from rhs/jac callbacks; keep the value so the -// callback contracts and the historical control flow stay byte-identical. -#ifndef GSL_SUCCESS -#define GSL_SUCCESS 0 -#endif - -double adiabat = 5.0/3.0; -//double adiabat = 1.0e6; - -/************************** RWM *****************************************/ -/******************from Bondenson et al. (1996)*************************************************/ - -// Doppler shifted frequency - -inline complex omega_D (double r, void * params) -{ -imhd_zone const * zone = (const imhd_zone *) params; - -int m = zone->wd->m; -double kz = (zone->wd->n)/(zone->sd->bs->rtor); -complex omega = zone->wd->olab; - -double Vt; eval_Vt (r, zone->bp, &Vt); - -double Vz; eval_Vz (r, zone->bp, &Vz); - -return omega - (m/r)*Vt - kz*Vz; -} - -/*******************************************************************/ - - // function T - -inline complex T_flow (double r, void * params) -{ -imhd_zone const * zone = (const imhd_zone *) params; - -double mdens; eval_mass_density (r, zone->bp, &mdens); - -double Bt; eval_Bt (r, zone->bp, &Bt); - -double F = Ffunc (r,params); - -complex w = omega_D (r, params); - -double Vt; eval_Vt (r, zone->bp, &Vt); - -return F*Bt/(4.0*pi) + mdens*w*Vt; -} - -/*******************************************************************/ - -//function A - -inline complex A_flow (double r, void * params) -{ -imhd_zone const * zone = (const imhd_zone *) params; - -double mdens; eval_mass_density (r, zone->bp, &mdens); - -double F = Ffunc (r,params); - -complex w = omega_D (r, params); - -return mdens*w*w - F*F/(4.0*pi); -} - -/*******************************************************************/ - -// function Q - -inline complex Q_flow (double r, void * params) -{ -imhd_zone const * zone = (const imhd_zone *) params; - -double mdens; eval_mass_density (r, zone->bp, &mdens); - -double F = Ffunc (r,params); - -double Vt; eval_Vt (r, zone->bp, &Vt); - -double Bt; eval_Bt (r, zone->bp, &Bt); - -complex T = T_flow (r, params); - -complex w = omega_D (r, params); - -complex A = A_flow (r,params); - -return mdens*(w*w*(Bt*Bt/(4.0*pi) - mdens*Vt*Vt) + 1.0/(4.0*pi)*(Bt*w + F*Vt)*(Bt*w + F*Vt)); -} - -/*******************************************************************/ - -// function S - -inline complex S_flow (double r, void * params) -{ -imhd_zone const * zone = (const imhd_zone *) params; - -double mdens; eval_mass_density (r, zone->bp, &mdens); - -double F = Ffunc (r,params); - -double Bt; eval_Bt (r, zone->bp, &Bt); - -double Bz; eval_Bz (r, zone->bp, &Bz); - -complex w = omega_D (r, params); - -double R[2]; eval_p_dp (r, zone->bp, R); double press = R[0]; - -return ((Bt*Bt + Bz*Bz)/(4.0*pi) + adiabat*press)*mdens*w*w - adiabat*press*F*F/(4.0*pi); -} - -/*******************************************************************/ - -// function C11 - -inline complex C11_flow (double r, void * params) -{ -imhd_zone const * zone = (const imhd_zone *) params; - -double mdens; eval_mass_density (r, zone->bp, &mdens); - -int m = zone->wd->m; - -complex w = omega_D (r, params); - -complex Q = Q_flow (r, params); - -complex S = S_flow (r, params); - -complex T = T_flow (r, params); - -return mdens*w*w*Q/(r*r) - 2.0*m*S*T/(r*r*r); -} - -/*******************************************************************/ - -// function C12 - -inline complex C12_flow (double r, void * params) -{ -imhd_zone const * zone = (const imhd_zone *) params; - -double mdens; eval_mass_density (r, zone->bp, &mdens); - -int m = zone->wd->m; -double kz = (zone->wd->n)/(zone->sd->bs->rtor); - -complex S = S_flow (r, params); - -complex w = omega_D (r, params); - -return mdens*mdens*w*w*w*w - (kz*kz + m*m/(r*r))*S; -} - -/*******************************************************************/ - -// function C21 - -inline complex C21_flow (double r, void * params) -{ -imhd_zone const * zone = (const imhd_zone *) params; - -complex S = S_flow (r, params); - -complex A = A_flow (r, params); - -complex T = T_flow (r, params); - -complex Q = Q_flow (r, params); - -complex C4 = C4_flow (r, params); - -return A*S*C4/r - 4.0*S*T*T/(r*r*r) + Q*Q/(r*r*r); -} - -/*******************************************************************/ - -// function C22 - -inline complex C22_flow (double r, void * params) -{ -return r*C11_flow (r, params); -} - -/*******************************************************************/ - -// functio to be derived inside C4 - -inline double func_deriv_in_C4 (double r, void * params) -{ -imhd_zone const * zone = (const imhd_zone *) params; - -double mdens; eval_mass_density (r, zone->bp, &mdens); - -double Vt; eval_Vt (r, zone->bp, &Vt); - -double Bt; eval_Bt (r, zone->bp, &Bt); - -return ((Bt*Bt)/(4.0*pi) - mdens*Vt*Vt)/(r*r); -} - -/*******************************************************************/ - -// function C4 - -inline complex C4_flow (double r, void * params) -{ -imhd_zone const * zone = (const imhd_zone *) params; - -double der, h = 1.0e-3, abserr; - -fortnum_deriv_central (&func_deriv_in_C4, r, h, &der, &abserr, params); - -complex A = A_flow (r, params); - -return A + r*der; -} - -/*******************************************************************/ - -// 2nd order ODE for eigenmode solving - -int rhs_flow (double r, const double y[], double dy[], void * params) -{ -const imhd_zone * zone = (const imhd_zone *) params; - -complex C11 = C11_flow (r, params); -complex C12 = C12_flow (r, params); -complex C21 = C21_flow (r, params); -complex C22 = C22_flow (r, params); - -complex A = A_flow (r, params); -complex S = S_flow (r, params); - -complex f = y[0] + I*y[1]; //(r*dzeta) -complex g = y[2] + I*y[3]; //(pressure) - -complex df = (C11*f - C12*g)/(A*S)*r; -complex dg = (C21*f - C22*g)/(A*S); - -dy[0] = real(df); -dy[1] = imag(df); -dy[2] = real(dg); -dy[3] = imag(dg); - -return GSL_SUCCESS; -} - -/*******************************************************************/ - -// fortnum_ode_rhs adapter: forwards to the historical rhs_flow, dropping the -// GSL return code (errors are signalled via the integrator status). -static void rhs_flow_fn (double r, int n, const double y[], double dydt[], - void *ctx) -{ -(void) n; -rhs_flow (r, y, dydt, ctx); -} - -/*******************************************************************/ - -void imhd_zone::calculate_basis_flow_gsl (void) -{ -//for tests only, use general cvode version! - -if (!(bc1 == BOUNDARY_CENTER || bc2 == BOUNDARY_IDEALWALL)) -{ - fprintf (stdout, "\nimhd::calculate_basis_incompressible_gsl: zone=%d: error!", index); - exit (1); -} - -const int Neq = 4; //2 real eqs, 2 imag eqs for (r*zeta), pressure - -double t, tfinal; - -double y[4]; - -int ind; - -if (bc1 == BOUNDARY_CENTER) -{ - t = r1; - tfinal = r2; - - //y start for integrator: r*zeta ~ r^|m| - y[0] = pow(t, abs(wd->m)); - y[1] = 0.0; - - complex rzeta = pow (t, abs(wd->m)); - - complex drzeta = abs(wd->m)*pow (t, abs(wd->m)-1); - - complex pstar = (C11_flow(t, this)*rzeta - S_flow(t, this)*A_flow(t, this)*drzeta/t)/ - C12_flow(t, this); - y[2] = real (pstar); - y[3] = imag (pstar); - - ind = 0; //index of a fundamental solution which is regular at the boundary -} -else if (bc2 == BOUNDARY_IDEALWALL) -{ - t = r2; - tfinal = r1; - - y[0] = 0.0; - y[1] = 0.0; - y[2] = 1.0; - y[3] = 0.0; - - ind = 0; //index of a fundamental solution which is regular at the boundary -} -else -{ - fprintf (stdout, "\nimhd::calculate_basis_compressible_gsl: error!"); - exit (1); -} - -size_t iter; - -//arrays: -double *grid = new double[max_dim]; - -double *syst = new double[max_dim*Nwaves*Ncomps*2]; - -// Evolve continuously with the GSL-faithful rk8pd stepper, recording every -// accepted step as the radial grid. This mirrors the original -// gsl_odeiv_evolve_apply loop under gsl_odeiv_control_y_new(eps_abs, eps_rel): -// the integrator carried its adaptive step across the interval and the loop -// stored (t, y) after each accepted step. The dop853 path used a different -// 8(7) error norm and accepted-step mesh, drifting the linear response from -// the golden. The starting step matches the golden: h0 = 1e-6 in the -// integration direction. -double h0 = (1.0e-6)*signum(tfinal-t); - -void *ode = fortnum_rk8pd_create (&rhs_flow_fn, Neq, h0, - eps_abs, eps_rel, 100000, this); - -if (!ode) -{ - fprintf (stderr, "\ncalculate_basis_flow_gsl: failed to create ODE evolver"); - exit (1); -} - -//initial point: -iter = 0; -grid[iter] = t; - -syst[ib(iter, ind, 6, 0)] = y[0]; -syst[ib(iter, ind, 6, 1)] = y[1]; -syst[ib(iter, ind, 7, 0)] = y[2]; -syst[ib(iter, ind, 7, 1)] = y[3]; - -state_to_EB_compressible_flow (grid[iter], syst+ib(iter, ind, 6, 0), syst+ib(iter, ind, 0, 0)); - -while (t != tfinal) -{ - int ode_status = fortnum_rk8pd_step_to (ode, &t, tfinal, y); - - if (ode_status != FORTNUM_OK) - { - fprintf (stderr, "\ncalculate_basis_flow_gsl: ODE solver failed at r = %le", t); - exit (1); - } - - //store values: - iter++; - grid[iter] = t; - - syst[ib(iter, ind, 6, 0)] = y[0]; - syst[ib(iter, ind, 6, 1)] = y[1]; - syst[ib(iter, ind, 7, 0)] = y[2]; - syst[ib(iter, ind, 7, 1)] = y[3]; - - state_to_EB_compressible_flow (grid[iter], syst+ib(iter, ind, 6, 0), syst+ib(iter, ind, 0, 0)); - - if (iter == max_dim-1) - { - fprintf (stderr, "\nMaximum allowed iteration number is reached: iter=%d r=%le", (int)iter, t); - exit (1); - } -} - -fortnum_rk8pd_destroy (ode); - -dim = iter + 1; - -//zone class data allocation: -r = new double[dim]; - -int len = dim*Nwaves*Ncomps*2; - -basis = new double[len]; - -for (int i=0; i-1; j--) - { - r[k] = grid[j]; - - for (int comp=0; comp rzeta = state[0] + I*state[1]; //(r*zeta) -complex press = state[2] + I*state[3]; //(pressure) - -complex zeta_r = rzeta/r; - -//wave: -double kt = (wd->m)/r; -double kz = (wd->n)/(sd->bs->rtor); -double k0k0 = kt*kt + kz*kz; - -//background: -double R[4]; - -eval_Bt_dBt_Bz_dBz (r, bp, R); - -double B0t = R[0]; -double dB0t = R[1]; -double B0z = R[2]; -double dB0z = R[3]; - -double F = kt*B0t + kz*B0z; //double G = kt*B0z - kz*B0t; - -double mdens; eval_mass_density (r, bp, &mdens); - -double Vt; eval_Vt (r, bp, &Vt); - -double Vz; eval_Vz (r, bp, &Vz); - -// frequency omega: -complex omega = (wd->olab); - -complex omega_Dop = omega - kt*Vt - kz*Vz; - -double K[2]; eval_p_dp (r, bp, K); double press_0 = K[0]; double dpress_0 = K[1]; - -complex drzeta = r*(C11_flow(r, this)*rzeta - C12_flow(r, this)*press)/ - (S_flow(r, this)*A_flow(r, this)); - -////////////////////////////////////////////////// - -complex A = - kz*adiabat*press_0*kt + B0t*B0z*k0k0/4.0/pi; - -complex M = zeta_r*I*(F/4.0/pi*dB0z + kz*dpress_0 - kt/4.0/pi*dB0z*B0t - - - kz/4.0/pi*B0t*(B0t/r - dB0t)) + - - drzeta*I*(kz*B0t*B0t/4.0/pi/r - kt/4.0/pi*B0t*B0z/r + kz*adiabat*press_0/r); - -complex G = zeta_r*I*(F/4.0/pi*(B0t/r + dB0t) + 2.0*omega_Dop*mdens*Vt/r + dpress_0*kt + - - kt/4.0/pi*B0z*dB0z + kz/4.0/pi*B0z*(B0t/r - dB0t)) + - - drzeta*I*(kt/4.0/pi*B0z*B0z/r - kz/4.0/pi/r*B0z*B0t + kt*adiabat*press_0/r); - -complex N = -mdens*omega_Dop*omega_Dop + kz*kz*adiabat*press_0 + B0t*B0t/4.0/pi*k0k0; - -complex H = -mdens*omega_Dop*omega_Dop + kt*kt*adiabat*press_0 + B0z*B0z/4.0/pi*k0k0; - -/////////////////////////////////////////////////// - -complex dzeta_r = (drzeta - zeta_r)/r; - -complex zeta_t = (M*A+G*N)/(N*H-A*A); - -complex zeta_z = (G*A+M*H)/(N*H-A*A); - -// perturbated fields: -complex alpha = zeta_t*B0z - zeta_z*B0t; - -//Br: -complex Br = I*F*zeta_r; - -//Bt: -complex Bt = - (dzeta_r*B0t + zeta_r*dB0t) + I*kz*alpha; - -//Bz: -complex Bz = - (drzeta*B0z + rzeta*dB0z)/r - I*kt*alpha; - -//Er: -complex Er = O; - -//Et: -complex Et = O; - -//Ez: -complex Ez = O; - -//setup output values: -EB[0] = real (Er); EB[1] = imag (Er); -EB[2] = real (Et); EB[3] = imag (Et); -EB[4] = real (Ez); EB[5] = imag (Ez); -EB[6] = real (Br); EB[7] = imag (Br); -EB[8] = real (Bt); EB[9] = imag (Bt); -EB[10] = real (Bz); EB[11] = imag (Bz); -EB[12] = real (rzeta); EB[13] = imag (rzeta); -EB[14] = real (drzeta); EB[15] = imag (drzeta); - -//check: -/*complex divzeta = drzeta/r + I*(kt*zeta_t + kz*zeta_z); -fprintf (stdout, "\nr = %le\tdrzeta/r = %le %+lei", r, real(drzeta/r), imag(drzeta/r)); -fprintf (stdout, "\nzeta_t = %le %+lei", real(zeta_t), imag(zeta_t)); -fprintf (stdout, "\nzeta_z = %le %+lei", real(zeta_z), imag(zeta_z)); -fprintf (stdout, "\ndivzeta = %le %+lei", real(divzeta), imag(divzeta));*/ -} - -/*******************************************************************/ - -int jac_flow (double r, const double y[], double *dfdy, double dfdt[], void *params) -{ -fprintf (stdout, "\nwarning: jac_flow is called!"); - -return GSL_SUCCESS; -} - -/*******************************************************************/ diff --git a/KiLCA/imhd/compressible_flow.h b/KiLCA/imhd/compressible_flow.h deleted file mode 100644 index 2afdd1db..00000000 --- a/KiLCA/imhd/compressible_flow.h +++ /dev/null @@ -1,58 +0,0 @@ -/*! \file compressible_flow.h - \brief The declarations of functions implementing ideal compressible MHD equations with plasma flows. -*/ - -#ifndef IMHD_COMPRESSIBLE_FLOW_INCLUDE - -#define IMHD_COMPRESSIBLE_FLOW_INCLUDE - -#include "constants.h" -#include "imhd_zone.h" - -/*******************************************************************/ - -struct diff_params -{ - const imhd_zone * zone; //pointer to imhd object - int part; //real or imag -}; - -/*******************************************************************/ - -int rhs_flow (double r, const double y[], double dy[], void * params); - -int jac_flow (double r, const double y[], double *dfdy, double dfdt[], void *params); - -/*****************************RWM Bondenson et al.(1987)**************************************/ - -inline complex omega_D (double r, void * params); - -inline complex Q_flow (double r, void * params); - -inline complex A_flow (double r, void * params); - -inline complex T_flow (double r, void * params); - -inline complex S_flow (double r, void * params); - -inline complex C11_flow (double r, void * params); - -inline complex C12_flow (double r, void * params); - -inline complex C21_flow (double r, void * params); - -inline complex C22_flow (double r, void * params); - -inline complex C4_flow (double r, void * params); - -inline double func_deriv_in_C4 (double r, void * params); - -/*******************************************************************/ - -extern "C" -{ -} - -/*******************************************************************/ - -#endif diff --git a/KiLCA/imhd/compressible_flow_m.f90 b/KiLCA/imhd/compressible_flow_m.f90 new file mode 100644 index 00000000..366c18cb --- /dev/null +++ b/KiLCA/imhd/compressible_flow_m.f90 @@ -0,0 +1,434 @@ +!> Compressible ideal-MHD basis calculation with background flows, for +!> imhd_zone version 1 (formerly compressible_flow.{h,cpp}, the RWM +!> formulation of Bondenson et al. 1996). Same fortnum upgrade (native +!> rk8pd/deriv_central instead of the C-ABI callback shims) as +!> kilca_incompressible_m, whose Ffunc/zone_ctx_t/signum are reused here. +module kilca_compressible_flow_m + use, intrinsic :: iso_c_binding, only: c_double, c_null_ptr + use constants, only: dp, pi + use kilca_zone_m, only: zone_t, BOUNDARY_CENTER, BOUNDARY_IDEALWALL + use kilca_background_data_m, only: eval_Bt, eval_Bz, eval_Vt, eval_Vz, & + eval_mass_density, eval_p_dp, eval_Bt_dBt_Bz_dBz + use kilca_incompressible_m, only: zone_ctx_t, Ffunc, signum + use fortnum_status, only: fortnum_status_t, FORTNUM_OK + use fortnum_ode_rk8pd, only: rk8pd_state_t, rk8pd_evolve_init, rk8pd_evolve_apply + use fortnum_multiroot, only: deriv_central + implicit none + private + + public :: calculate_basis_flow, state_to_EB_compressible_flow, rhs_flow + + complex(dp), parameter :: cmplx_zero = (0.0_dp, 0.0_dp) + complex(dp), parameter :: cmplx_i = (0.0_dp, 1.0_dp) + real(dp), parameter :: deriv_h = 1.0e-3_dp + real(dp), parameter :: adiabat = 5.0_dp/3.0_dp + + interface + function get_background_rtor() bind(C, name="get_background_rtor_") result(rtor) + import :: c_double + real(c_double) :: rtor + end function get_background_rtor + end interface + + external :: normalize_imhd_basis + +contains + + !> Doppler-shifted frequency. + complex(dp) function omega_D(zone, r) result(w) + class(zone_t), pointer, intent(in) :: zone + real(dp), intent(in) :: r + real(dp) :: kz, Vt(1), Vz(1) + kz = real(zone%wd%n, dp)/get_background_rtor() + call eval_Vt(r, c_null_ptr, Vt) + call eval_Vz(r, c_null_ptr, Vz) + w = zone%wd%olab - (real(zone%wd%m, dp)/r)*Vt(1) - kz*Vz(1) + end function omega_D + + complex(dp) function T_flow(zone, r) result(T) + class(zone_t), pointer, intent(in) :: zone + real(dp), intent(in) :: r + real(dp) :: mdens(1), Bt(1), F, Vt(1) + complex(dp) :: w + call eval_mass_density(r, c_null_ptr, mdens) + call eval_Bt(r, c_null_ptr, Bt) + F = Ffunc(zone, r) + w = omega_D(zone, r) + call eval_Vt(r, c_null_ptr, Vt) + T = F*Bt(1)/(4.0_dp*pi) + mdens(1)*w*Vt(1) + end function T_flow + + complex(dp) function A_flow(zone, r) result(A) + class(zone_t), pointer, intent(in) :: zone + real(dp), intent(in) :: r + real(dp) :: mdens(1), F + complex(dp) :: w + call eval_mass_density(r, c_null_ptr, mdens) + F = Ffunc(zone, r) + w = omega_D(zone, r) + A = mdens(1)*w*w - F*F/(4.0_dp*pi) + end function A_flow + + !> Q_flow's `A` local (the oracle's A_flow(r,this)) is computed and + !> discarded in the C++ source; A_flow has no side effects, so dropping + !> that dead call here changes nothing observable. + complex(dp) function Q_flow(zone, r) result(Q) + class(zone_t), pointer, intent(in) :: zone + real(dp), intent(in) :: r + real(dp) :: mdens(1), F, Vt(1), Bt(1) + complex(dp) :: T, w + call eval_mass_density(r, c_null_ptr, mdens) + F = Ffunc(zone, r) + call eval_Vt(r, c_null_ptr, Vt) + call eval_Bt(r, c_null_ptr, Bt) + T = T_flow(zone, r) + w = omega_D(zone, r) + Q = mdens(1)*(w*w*(Bt(1)*Bt(1)/(4.0_dp*pi) - mdens(1)*Vt(1)*Vt(1)) + & + 1.0_dp/(4.0_dp*pi)*(Bt(1)*w + F*Vt(1))*(Bt(1)*w + F*Vt(1))) + end function Q_flow + + complex(dp) function S_flow(zone, r) result(S) + class(zone_t), pointer, intent(in) :: zone + real(dp), intent(in) :: r + real(dp) :: mdens(1), F, Bt(1), Bz(1), press(2) + complex(dp) :: w + call eval_mass_density(r, c_null_ptr, mdens) + F = Ffunc(zone, r) + call eval_Bt(r, c_null_ptr, Bt) + call eval_Bz(r, c_null_ptr, Bz) + w = omega_D(zone, r) + call eval_p_dp(r, c_null_ptr, press) + S = ((Bt(1)*Bt(1) + Bz(1)*Bz(1))/(4.0_dp*pi) + adiabat*press(1))*mdens(1)*w*w & + - adiabat*press(1)*F*F/(4.0_dp*pi) + end function S_flow + + complex(dp) function C11_flow(zone, r) result(C11) + class(zone_t), pointer, intent(in) :: zone + real(dp), intent(in) :: r + real(dp) :: mdens(1) + complex(dp) :: w, Q, S, T + call eval_mass_density(r, c_null_ptr, mdens) + w = omega_D(zone, r) + Q = Q_flow(zone, r) + S = S_flow(zone, r) + T = T_flow(zone, r) + C11 = mdens(1)*w*w*Q/(r*r) - 2.0_dp*real(zone%wd%m, dp)*S*T/(r*r*r) + end function C11_flow + + complex(dp) function C12_flow(zone, r) result(C12) + class(zone_t), pointer, intent(in) :: zone + real(dp), intent(in) :: r + real(dp) :: mdens(1), kz + complex(dp) :: S, w + call eval_mass_density(r, c_null_ptr, mdens) + kz = real(zone%wd%n, dp)/get_background_rtor() + S = S_flow(zone, r) + w = omega_D(zone, r) + C12 = mdens(1)*mdens(1)*w*w*w*w - (kz*kz + real(zone%wd%m, dp)**2/(r*r))*S + end function C12_flow + + complex(dp) function C21_flow(zone, r) result(C21) + class(zone_t), pointer, intent(in) :: zone + real(dp), intent(in) :: r + complex(dp) :: S, A, T, Q, C4 + S = S_flow(zone, r) + A = A_flow(zone, r) + T = T_flow(zone, r) + Q = Q_flow(zone, r) + C4 = C4_flow(zone, r) + C21 = A*S*C4/r - 4.0_dp*S*T*T/(r*r*r) + Q*Q/(r*r*r) + end function C21_flow + + complex(dp) function C22_flow(zone, r) result(C22) + class(zone_t), pointer, intent(in) :: zone + real(dp), intent(in) :: r + C22 = r*C11_flow(zone, r) + end function C22_flow + + real(dp) function func_deriv_in_C4(r, ctx) result(res) + real(dp), intent(in) :: r + class(*), intent(in), optional :: ctx + real(dp) :: mdens(1), Vt(1), Bt(1) + select type (ctx) + type is (zone_ctx_t) + call eval_mass_density(r, c_null_ptr, mdens) + call eval_Vt(r, c_null_ptr, Vt) + call eval_Bt(r, c_null_ptr, Bt) + res = (Bt(1)*Bt(1)/(4.0_dp*pi) - mdens(1)*Vt(1)*Vt(1))/(r*r) + end select + end function func_deriv_in_C4 + + complex(dp) function C4_flow(zone, r) result(C4) + class(zone_t), pointer, intent(in) :: zone + real(dp), intent(in) :: r + real(dp) :: der, abserr + type(fortnum_status_t) :: status + type(zone_ctx_t) :: ctx + complex(dp) :: A + + ctx%zone => zone + call deriv_central(func_deriv_in_C4, r, deriv_h, der, abserr, status, ctx) + + A = A_flow(zone, r) + C4 = A + r*der + end function C4_flow + + !> Folds the oracle's rhs_flow (GSL-style int return) and its rhs_flow_fn + !> fortnum_ode_rhs adapter into one ode_rhs_t-shaped routine. + subroutine rhs_flow(r, y, dydt, ctx) + real(dp), intent(in) :: r + real(dp), intent(in) :: y(:) + real(dp), intent(out) :: dydt(:) + class(*), intent(in), optional :: ctx + + class(zone_t), pointer :: zone + complex(dp) :: C11, C12, C21, C22, A, S, f, g, df, dg + + zone => null() + select type (ctx) + type is (zone_ctx_t) + zone => ctx%zone + end select + + C11 = C11_flow(zone, r) + C12 = C12_flow(zone, r) + C21 = C21_flow(zone, r) + C22 = C22_flow(zone, r) + A = A_flow(zone, r) + S = S_flow(zone, r) + + f = cmplx(y(1), y(2), dp) ! r*zeta + g = cmplx(y(3), y(4), dp) ! pressure + + df = (C11*f - C12*g)/(A*S)*r + dg = (C21*f - C22*g)/(A*S) + + dydt(1) = real(df, dp) + dydt(2) = aimag(df) + dydt(3) = real(dg, dp) + dydt(4) = aimag(dg) + end subroutine rhs_flow + + !> Mirrors imhd_zone::calculate_basis_flow_gsl exactly, including the + !> oracle's own copy-paste artifact: the bc1/bc2 sanity-check error + !> message names "calculate_basis_incompressible_gsl" even though this is + !> the flow path. + subroutine calculate_basis_flow(self) + class(zone_t), intent(inout), target :: self + + class(zone_t), pointer :: zone_ptr + integer, parameter :: Neq = 4 + real(dp) :: t, tfinal + real(dp) :: y(Neq) + integer :: ind + real(dp), allocatable :: grid(:) + complex(dp), allocatable :: syst(:, :, :) + real(dp) :: h0 + type(rk8pd_state_t) :: ode_state + type(fortnum_status_t) :: status + type(zone_ctx_t) :: ctx + integer :: nfev, iter, j, k + complex(dp) :: EB(8), rzeta, drzeta, pstar + logical :: valid_bc + + valid_bc = (self%bc1 == BOUNDARY_CENTER .or. self%bc2 == BOUNDARY_IDEALWALL) + if (.not. valid_bc) then + write (*, '(a,i0,a)') & + 'imhd::calculate_basis_incompressible_gsl: zone=', self%index, & + ': error!' + stop 1 + end if + + zone_ptr => self + ctx%zone => zone_ptr + + if (self%bc1 == BOUNDARY_CENTER) then + t = self%r1 + tfinal = self%r2 + + y(1) = t**abs(self%wd%m) + y(2) = 0.0_dp + + rzeta = cmplx(t**abs(self%wd%m), 0.0_dp, dp) + drzeta = cmplx(real(abs(self%wd%m), dp)*t**(abs(self%wd%m) - 1), 0.0_dp, dp) + + pstar = (C11_flow(zone_ptr, t)*rzeta - & + S_flow(zone_ptr, t)*A_flow(zone_ptr, t)*drzeta/t)/C12_flow(zone_ptr, t) + y(3) = real(pstar, dp) + y(4) = aimag(pstar) + + ind = 0 + else if (self%bc2 == BOUNDARY_IDEALWALL) then + t = self%r2 + tfinal = self%r1 + + y(1) = 0.0_dp + y(2) = 0.0_dp + y(3) = 1.0_dp + y(4) = 0.0_dp + + ind = 0 + else + write (*, '(a)') 'imhd::calculate_basis_compressible_gsl: error!' + stop 1 + end if + + allocate (grid(self%max_dim)) + allocate (syst(self%Ncomps, self%Nwaves, self%max_dim)) + syst = cmplx_zero + + h0 = 1.0e-6_dp*real(signum(tfinal - t), dp) + + call rk8pd_evolve_init(ode_state, Neq, h0, status) + if (status%code /= FORTNUM_OK) then + write (*, '(a)') 'calculate_basis_flow_gsl: failed to create ODE evolver' + stop 1 + end if + + iter = 1 + grid(iter) = t + call state_to_EB_compressible_flow(zone_ptr, grid(iter), y, EB) + syst(:, ind + 1, iter) = EB + + nfev = 0 + do while (t /= tfinal) + call rk8pd_evolve_apply(rhs_flow, ode_state, t, tfinal, y, & + self%eps_abs, self%eps_rel, 100000, nfev, status, ctx, & + single_step=.true.) + + if (status%code /= FORTNUM_OK) then + write (*, '(a,es12.4e3)') & + 'calculate_basis_flow_gsl: ODE solver failed at r = ', t + stop 1 + end if + + iter = iter + 1 + grid(iter) = t + call state_to_EB_compressible_flow(zone_ptr, grid(iter), y, EB) + syst(:, ind + 1, iter) = EB + + if (iter == self%max_dim) then + write (*, '(a,i0,a,es12.4e3)') & + 'Maximum allowed iteration number is reached: iter=', iter, ' r=', t + stop 1 + end if + end do + + self%dim = iter + + if (allocated(self%r)) deallocate (self%r) + allocate (self%r(self%dim)) + if (allocated(self%basis)) deallocate (self%basis) + allocate (self%basis(self%Ncomps, self%Nwaves, self%dim)) + self%basis = cmplx_zero + + if (self%bc1 == BOUNDARY_CENTER) then + do j = 1, self%dim + self%r(j) = grid(j) + self%basis(:, ind + 1, j) = syst(:, ind + 1, j) + end do + call normalize_imhd_basis(self%Ncomps, self%Nwaves, self%dim, self%basis, & + ind, self%dim - 1) + else if (self%bc2 == BOUNDARY_IDEALWALL) then + k = 1 + do j = self%dim, 1, -1 + self%r(k) = grid(j) + self%basis(:, ind + 1, k) = syst(:, ind + 1, j) + k = k + 1 + end do + call normalize_imhd_basis(self%Ncomps, self%Nwaves, self%dim, self%basis, & + ind, 0) + else + write (*, '(a)') 'imhd::calculate_basis_compressible_gsl: error!' + stop 1 + end if + + deallocate (grid, syst) + end subroutine calculate_basis_flow + + !> Mirrors imhd_zone::state_to_EB_compressible_flow exactly. Note the + !> oracle's own subtlety, preserved here: EB's last complex slot is + !> assigned the locally recomputed `drzeta` (from the C11/C12/S/A + !> formula below), NOT the raw input `press` state component that feeds + !> into that formula - the header comment calling it "(pressure)" is + !> stale. + subroutine state_to_EB_compressible_flow(zone, r, state, EB) + class(zone_t), pointer, intent(in) :: zone + real(dp), intent(in) :: r + real(dp), intent(in) :: state(4) + complex(dp), intent(out) :: EB(8) + + complex(dp) :: rzeta, press, zeta_r, drzeta, dzeta_r + real(dp) :: kt, kz, k0k0 + real(dp) :: Rb(4), B0t, dB0t, B0z, dB0z, F + real(dp) :: mdens(1), Vt(1), Vz(1), Kp(2), press_0, dpress_0 + complex(dp) :: omega, omega_Dop + complex(dp) :: Acoef, M, G, N, H, zeta_t, zeta_z, alpha + complex(dp) :: Br, Bt, Bz, Er, Et, Ez + + rzeta = cmplx(state(1), state(2), dp) + press = cmplx(state(3), state(4), dp) + + zeta_r = rzeta/r + + kt = real(zone%wd%m, dp)/r + kz = real(zone%wd%n, dp)/get_background_rtor() + k0k0 = kt*kt + kz*kz + + call eval_Bt_dBt_Bz_dBz(r, c_null_ptr, Rb) + B0t = Rb(1); dB0t = Rb(2); B0z = Rb(3); dB0z = Rb(4) + + F = kt*B0t + kz*B0z + + call eval_mass_density(r, c_null_ptr, mdens) + call eval_Vt(r, c_null_ptr, Vt) + call eval_Vz(r, c_null_ptr, Vz) + + omega = zone%wd%olab + omega_Dop = omega - kt*Vt(1) - kz*Vz(1) + + call eval_p_dp(r, c_null_ptr, Kp) + press_0 = Kp(1); dpress_0 = Kp(2) + + drzeta = r*(C11_flow(zone, r)*rzeta - C12_flow(zone, r)*press)/ & + (S_flow(zone, r)*A_flow(zone, r)) + + Acoef = -kz*adiabat*press_0*kt + B0t*B0z*k0k0/4.0_dp/pi + + M = zeta_r*cmplx_i*(F/4.0_dp/pi*dB0z + kz*dpress_0 - kt/4.0_dp/pi*dB0z*B0t - & + kz/4.0_dp/pi*B0t*(B0t/r - dB0t)) + & + drzeta*cmplx_i*(kz*B0t*B0t/4.0_dp/pi/r - kt/4.0_dp/pi*B0t*B0z/r + & + kz*adiabat*press_0/r) + + G = zeta_r*cmplx_i*(F/4.0_dp/pi*(B0t/r + dB0t) + & + 2.0_dp*omega_Dop*mdens(1)*Vt(1)/r + dpress_0*kt + & + kt/4.0_dp/pi*B0z*dB0z + kz/4.0_dp/pi*B0z*(B0t/r - dB0t)) + & + drzeta*cmplx_i*(kt/4.0_dp/pi*B0z*B0z/r - kz/4.0_dp/pi/r*B0z*B0t + & + kt*adiabat*press_0/r) + + N = -mdens(1)*omega_Dop*omega_Dop + kz*kz*adiabat*press_0 & + + B0t*B0t/4.0_dp/pi*k0k0 + H = -mdens(1)*omega_Dop*omega_Dop + kt*kt*adiabat*press_0 & + + B0z*B0z/4.0_dp/pi*k0k0 + + dzeta_r = (drzeta - zeta_r)/r + + zeta_t = (M*Acoef + G*N)/(N*H - Acoef*Acoef) + zeta_z = (G*Acoef + M*H)/(N*H - Acoef*Acoef) + + alpha = zeta_t*B0z - zeta_z*B0t + + Br = cmplx_i*F*zeta_r + Bt = -(dzeta_r*B0t + zeta_r*dB0t) + cmplx_i*kz*alpha + Bz = -(drzeta*B0z + rzeta*dB0z)/r - cmplx_i*kt*alpha + + Er = cmplx_zero + Et = cmplx_zero + Ez = cmplx_zero + + EB(1) = Er; EB(2) = Et; EB(3) = Ez + EB(4) = Br; EB(5) = Bt; EB(6) = Bz + EB(7) = rzeta; EB(8) = drzeta + end subroutine state_to_EB_compressible_flow + +end module kilca_compressible_flow_m diff --git a/KiLCA/imhd/imhd_zone.cpp b/KiLCA/imhd/imhd_zone.cpp deleted file mode 100644 index e663e64b..00000000 --- a/KiLCA/imhd/imhd_zone.cpp +++ /dev/null @@ -1,205 +0,0 @@ -/*! \file imhd_zone.cpp - \brief The implementation of imhd_zone class. -*/ - -#include "imhd_zone.h" -#include "mode.h" -#include "shared.h" -#include "inout.h" -#include "eval_back.h" - -/*****************************************************************************/ - -void imhd_zone::read_settings (char * file) -{ -read (file); //base class read function - -//derived class specific: -FILE *in; - -if ((in=fopen (file, "r"))==NULL) -{ - fprintf(stderr, "\nerror: hmedium_zone: read_settings: failed to open file %s\a\n", file); - exit(0); -} - -char *str_buf = new char[1024]; - -//skip lines (already readed and values are set): -read_line_2skip_it (in, &str_buf); -read_line_2skip_it (in, &str_buf); -read_line_2skip_it (in, &str_buf); -read_line_2skip_it (in, &str_buf); -read_line_2skip_it (in, &str_buf); -read_line_2skip_it (in, &str_buf); -read_line_2skip_it (in, &str_buf); -read_line_2skip_it (in, &str_buf); - -//Solution settings: -read_line_2skip_it (in, &str_buf); -read_line_2get_int (in, &(max_dim)); -read_line_2get_double (in, &(eps_rel)); -read_line_2get_double (in, &(eps_abs)); -read_line_2skip_it (in, &str_buf); - -//Space out settings: -read_line_2skip_it (in, &str_buf); -read_line_2get_int (in, &(deg)); -read_line_2get_double (in, &(reps)); -read_line_2get_double (in, &(aeps)); -read_line_2get_double (in, &(step)); -read_line_2skip_it (in, &str_buf); - -//Debugging settings: -read_line_2skip_it (in, &str_buf); -read_line_2get_int (in, &(flag_debug)); -read_line_2skip_it (in, &str_buf); - -fclose (in); - -Nwaves = 2; -Ncomps = 8; - -imhd_zone *pointer = this; - -set_imhd_data_module_ (&pointer); - -if (flag_debug) print_settings (); - -delete [] str_buf; -} - -/*****************************************************************************/ - -void imhd_zone::print_settings (void) -{ -print (); //base class print function -} - -/*****************************************************************************/ - -void imhd_zone::calc_basis_fields (int flag) -{ -switch (version) -{ - case 0: //incompressible without background flows with gsl integrator - calculate_basis_incompressible_gsl (); - break; - - case 1: //incompressible with background flows with gsl integrator - calculate_basis_flow_gsl (); - break; - - default: - fprintf (stderr, "\nerror: imhd_zone::calc_basis_fields: unknown code version."); - exit (1); -} - -//transform basis to the lab frame if needed! -} - -/*****************************************************************************/ - -void imhd_zone::copy_E_and_B_fields (double *EB_p) -{ -for (int node=0; nodewd->m)/r; -double kz = (zone->wd->n)/(zone->sd->bs->rtor); - -double BtBz[2]; - -eval_Bt_Bz (r, zone->bp, BtBz); - -return kt*BtBz[0] + kz*BtBz[1]; -} - -/*******************************************************************/ - -double Gfunc (double r, void *params) -{ -const imhd_zone *zone = (const imhd_zone *) params; - -//wave staff: -double kt = (zone->wd->m)/r; -double kz = (zone->wd->n)/(zone->sd->bs->rtor); - -double BtBz[2]; - -eval_Bt_Bz (r, zone->bp, BtBz); - -return kt*BtBz[1] - kz*BtBz[0]; -} - -/*******************************************************************/ - -complex calc_k_vals (const imhd_zone *zone, double r, double *kt, double *kz, - double *ks, double *kp, double *k2, double *kB, complex *kA) -{ -int m = zone->wd->m; -int n = zone->wd->n; -complex olab = zone->wd->olab; - -//wave staff: -*kt = m/r; -*kz = n/(zone->sd->bs->rtor); -*k2 = (*kt)*(*kt) + (*kz)*(*kz); - -//background stuff: -double R[5]; - -eval_B0_ht_hz_n0_Vz (r, zone->bp, R); - -double B0 = R[0]; -double ht = R[1]; -double hz = R[2]; -double n0 = R[3]; -double Vz = R[4]; - -*ks = hz*(*kt) - ht*(*kz); -*kp = ht*(*kt) + hz*(*kz); - -*kB = (*kp)*B0; - -double VA = B0/sqrt(4.0*pi*(zone->sd->bs->mass[0])*n0); - -*kA = (olab - (*kz)*Vz)/VA; - -return E - ((*kA)*(*kA))/((*kp)*(*kp)); //kfac -} - -/*******************************************************************/ - -void calc_k_vals_ (imhd_zone **zone_ptr, double *r, double *kt, double *kz, - double *ks, double *kp, double *k2, double *kB, - double *re_kA, double *im_kA, double *re_kfac, double *im_kfac) -{ -const imhd_zone *zone = (const imhd_zone *)(*zone_ptr); - -complex kfac, kA; - -kfac = calc_k_vals (zone, *r, kt, kz, ks, kp, k2, kB, &kA); - -*re_kA = real(kA); -*im_kA = imag(kA); - -*re_kfac = real(kfac); -*im_kfac = imag(kfac); -} - -/*******************************************************************/ diff --git a/KiLCA/imhd/imhd_zone.h b/KiLCA/imhd/imhd_zone.h deleted file mode 100644 index 4c3fc32e..00000000 --- a/KiLCA/imhd/imhd_zone.h +++ /dev/null @@ -1,117 +0,0 @@ -/*! \file imhd_zone.h - \brief The declaration of imhd_zone class. -*/ - -#ifndef IMHD_ZONE - -#define IMHD_ZONE - -#include -#include - -#include "zone.h" -#include "hmedium_zone.h" -#include "settings.h" -#include "background.h" -#include "wave_data.h" - -/*****************************************************************************/ - -/*! \class imhd_zone - \brief The class represents properties and data of a plasma zone described by ideal MHD equations. -*/ -class imhd_zone : public zone -{ -public: - inline int iF(int comp) - { - //indexing function for Er, Et, Ez, Br, Bt, Bz fields in a state vector - return comp; - } - - inline int iF(int node, int comp, int part) - { - //indexing function for E, B fields in EB state array - return part + 2*(iF(comp) + Ncomps*(node)); - } - -public: - imhd_zone (const settings *sd_p, const background *bp_p, const wave_data *wd_p, - char *path_p, int index_p) : zone (sd_p, bp_p, wd_p, path_p, index_p) {} - - ~imhd_zone (void) {} - - void read_settings (char * file); - - void print_settings (void); - - void calc_basis_fields (int flag = 0); - - void copy_E_and_B_fields (double *); - - void state_to_EB_incompressible (double, double *, double *); - - void calculate_basis_incompressible_gsl (void); - - void calculate_basis_flow_gsl (void); - - void state_to_EB_compressible_flow (double, double *, double *); - - void calc_final_fields (void) {} - - void calc_dispersion (void) {} - - void save_dispersion (void) {} - - void calc_all_quants (void) {} - - void save_all_quants (void) {} - - void eval_diss_power_density (double x, int type, int spec, double * dpd) - { - fprintf (stdout, "\nerror: eval_diss_power_density() is not implemented for the imhd_zone"); - } - - void eval_current_density (double x, int type, int spec, int comp, double * J) - { - fprintf (stdout, "\nerror: eval_current_density() is not implemented for the imhd_zone"); - } -}; - -/*****************************************************************************/ - -double Ffunc (double r, void *params); -double Gfunc (double r, void *params); - -complex calc_k_vals (const imhd_zone *zone, double r, double *kt, double *kz, double *ks, double *kp, double *k2, double *kB, complex *kA); - -/*****************************************************************************/ - -extern "C" -{ -void set_imhd_data_module_ (imhd_zone **); - -void calc_k_vals_ (imhd_zone **zone_ptr, double *r, double *kt, double *kz, - double *ks, double *kp, double *k2, double *kB, - double *re_kA, double *im_kA, double *re_kfac, double *im_kfac); - -void center_equations_imhd_ (int *Nw, int *len, imhd_zone **code, double *EB, int *neq, int *nvar, double *M, double *J); - -void infinity_equations_imhd_ (int *Nw, int *len, imhd_zone **code, double *EB, int *neq, int *nvar, double *M, double *J); - -void ideal_wall_equations_imhd_ (int *Nw, int *len, imhd_zone **code, double *EB, int *neq, int *nvar, double *M, double *J); - -void stitching_equations_imhd_hommed_ (int *Nw1, int *len1, imhd_zone **code1, double *EB1, - int *Nw2, int *len2, hmedium_zone **code2, double *EB2, - int *flg_ant, int *neq, int *nvar, double *M, double *J); - -void stitching_equations_imhd_imhd_ (int *Nw1, int *len1, imhd_zone **code1, double *EB1, - int *Nw2, int *len2, imhd_zone **code2, double *EB2, - int *flg_ant, int *neq, int *nvar, double *M, double *J); - -void normalize_imhd_basis_ (int * Ncomp, int * Nwaves, int * dim, double * basis, int * ind, int * node); -} - -/*****************************************************************************/ - -#endif diff --git a/KiLCA/imhd/imhd_zone_m.f90 b/KiLCA/imhd/imhd_zone_m.f90 new file mode 100644 index 00000000..21864fa5 --- /dev/null +++ b/KiLCA/imhd/imhd_zone_m.f90 @@ -0,0 +1,288 @@ +!> Ideal-MHD plasma zone, formerly the C++ imhd_zone class (imhd_zone.{h,cpp}). +!> imhd_zone adds no data members over the base zone in the C++ oracle - its +!> basis calculation, dispersion, and quantity hooks are split across +!> kilca_incompressible_m (version 0) and kilca_compressible_flow_m +!> (version 1), both of which operate on a bare class(zone_t) for the same +!> reason. The only extra state this Fortran type carries is own_handle, +!> bookkeeping the zone's own pool handle (the C++ oracle used `this` +!> directly; this port's handle-pool architecture has no equivalent +!> implicit self-reference, so read_settings needs somewhere to recover it +!> for set_imhd_data_module_). +module kilca_imhd_zone_m + use, intrinsic :: iso_c_binding, only: c_int, c_intptr_t, c_double, c_char, c_ptr, & + c_null_ptr + use constants, only: dp, pi + use kilca_wave_data_m, only: wave_data_t + use kilca_zone_m, only: zone_t, zone_register, zone_read, zone_print, skip_line, & + read_real_before_hash, read_int_before_hash, handle_to_zone + use kilca_incompressible_m, only: calculate_basis_incompressible + use kilca_compressible_flow_m, only: calculate_basis_flow + implicit none + private + + public :: imhd_zone_t + public :: imhd_zone_create + public :: calc_k_vals_ + + complex(dp), parameter :: cmplx_one = (1.0_dp, 0.0_dp) + + type, extends(zone_t) :: imhd_zone_t + integer(c_intptr_t) :: own_handle = 0_c_intptr_t + contains + procedure :: read_settings => imhd_read_settings + procedure :: print_settings => imhd_print_settings + procedure :: calc_basis_fields => imhd_calc_basis_fields + procedure :: copy_E_and_B_fields => imhd_copy_E_and_B_fields + procedure :: calc_final_fields => imhd_calc_final_fields + procedure :: calc_dispersion => imhd_calc_dispersion + procedure :: save_dispersion => imhd_save_dispersion + procedure :: calc_all_quants => imhd_calc_all_quants + procedure :: save_all_quants => imhd_save_all_quants + procedure :: eval_diss_power_density => imhd_eval_diss_power_density + procedure :: eval_current_density => imhd_eval_current_density + end type imhd_zone_t + + interface + function get_background_rtor() bind(C, name="get_background_rtor_") result(rtor) + import :: c_double + real(c_double) :: rtor + end function get_background_rtor + + function get_background_mass(i) bind(C, name="get_background_mass_") result(m) + import :: c_double, c_int + integer(c_int), value :: i + real(c_double) :: m + end function get_background_mass + end interface + + interface + subroutine eval_B0_ht_hz_n0_Vz(rval, bp, R) bind(C, name="eval_B0_ht_hz_n0_Vz") + import :: c_double, c_ptr + real(c_double), value :: rval + type(c_ptr), value :: bp + real(c_double), intent(out) :: R(*) + end subroutine eval_B0_ht_hz_n0_Vz + end interface + + external :: set_imhd_data_module + +contains + + function imhd_zone_create(sd_ptr, bp_ptr, wd_handle, path, index_p) & + result(handle) bind(C, name="imhd_zone_create_") + integer(c_intptr_t), value :: sd_ptr, bp_ptr, wd_handle + character(kind=c_char), intent(in) :: path(*) + integer(c_int), value :: index_p + integer(c_intptr_t) :: handle + + type(imhd_zone_t), pointer :: iz + class(zone_t), pointer :: zp + type(c_ptr) :: wd_cptr + + allocate (iz) + iz%bp = bp_ptr + iz%index = int(index_p) + iz%path = zone_c_string(path) + wd_cptr = transfer(wd_handle, wd_cptr) + call c_f_pointer_local(wd_cptr, iz%wd) + + zp => iz + handle = zone_register(zp) + iz%own_handle = handle + end function imhd_zone_create + + subroutine c_f_pointer_local(cptr, wd) + use, intrinsic :: iso_c_binding, only: c_f_pointer + type(c_ptr), intent(in) :: cptr + type(wave_data_t), pointer, intent(out) :: wd + call c_f_pointer(cptr, wd) + end subroutine c_f_pointer_local + + function zone_c_string(cstr) result(fstr) + use, intrinsic :: iso_c_binding, only: c_null_char + character(kind=c_char), intent(in) :: cstr(*) + character(len=1024) :: fstr + integer :: i + fstr = '' + i = 0 + do + if (cstr(i + 1) == c_null_char .or. i >= 1024) exit + fstr(i + 1:i + 1) = cstr(i + 1) + i = i + 1 + end do + end function zone_c_string + + !> Mirrors imhd_zone::read_settings: the base read() (8 lines), then a + !> fresh open re-skipping those same 8 lines (matching hmedium_zone's + !> double-open pattern), then Solution/Space out/Debugging settings - + !> note imhd_zone has no "Medium settings" section. The failed-open + !> error text below literally says "hmedium_zone" in the C++ oracle too + !> (a copy-paste artifact carried over unchanged into imhd_zone.cpp). + subroutine imhd_read_settings(self, file) + class(imhd_zone_t), intent(inout) :: self + character(len=*), intent(in) :: file + integer :: unit, ios, k + + call zone_read(self, file) + + open (newunit=unit, file=trim(file), status='old', action='read', iostat=ios) + if (ios /= 0) then + write (*, '(a,a)') & + 'error: hmedium_zone: read_settings: failed to open file ', trim(file) + stop 1 + end if + + do k = 1, 8 + call skip_line(unit) + end do + + call skip_line(unit) + call read_int_before_hash(unit, self%max_dim) + call read_real_before_hash(unit, self%eps_rel) + call read_real_before_hash(unit, self%eps_abs) + call skip_line(unit) + + call skip_line(unit) + call read_int_before_hash(unit, self%deg) + call read_real_before_hash(unit, self%reps) + call read_real_before_hash(unit, self%aeps) + call read_real_before_hash(unit, self%step) + call skip_line(unit) + + call skip_line(unit) + call read_int_before_hash(unit, self%flag_debug) + call skip_line(unit) + + close (unit) + + self%Nwaves = 2 + self%Ncomps = 8 + + call set_imhd_data_module(self%own_handle) + + if (self%flag_debug /= 0) call self%print_settings() + end subroutine imhd_read_settings + + subroutine imhd_print_settings(self) + class(imhd_zone_t), intent(in) :: self + call zone_print(self) + end subroutine imhd_print_settings + + subroutine imhd_calc_basis_fields(self, flag) + class(imhd_zone_t), intent(inout) :: self + integer, intent(in) :: flag + + select case (self%version) + case (0) + call calculate_basis_incompressible(self) + case (1) + call calculate_basis_flow(self) + case default + write (*, '(a)') & + 'error: imhd_zone::calc_basis_fields: unknown code version.' + stop 1 + end select + end subroutine imhd_calc_basis_fields + + !> Identical pattern to hmedium_zone_m's copy_E_and_B_fields: only the + !> first 6 of imhd_zone's 8 state-vector components (Er, Et, Ez, Br, Bt, + !> Bz) reach the lab-frame output; comps 6,7 ((r*zeta) and its + !> derivative/pressure proxy) are dropped here, matching the oracle's + !> `for (comp=0; comp<6; comp++)` loop bound. + subroutine imhd_copy_E_and_B_fields(self, EB_out) + class(imhd_zone_t), intent(in) :: self + real(dp), intent(out) :: EB_out(*) + integer :: node, comp + + do node = 0, self%dim - 1 + do comp = 0, 5 + EB_out(2*(comp + 6*node) + 1) = real(self%EB(comp + 1, node + 1), dp) + EB_out(2*(comp + 6*node) + 2) = aimag(self%EB(comp + 1, node + 1)) + end do + end do + end subroutine imhd_copy_E_and_B_fields + + subroutine imhd_calc_final_fields(self) + class(imhd_zone_t), intent(inout) :: self + end subroutine imhd_calc_final_fields + + subroutine imhd_calc_dispersion(self) + class(imhd_zone_t), intent(inout) :: self + end subroutine imhd_calc_dispersion + + subroutine imhd_save_dispersion(self) + class(imhd_zone_t), intent(inout) :: self + end subroutine imhd_save_dispersion + + subroutine imhd_calc_all_quants(self) + class(imhd_zone_t), intent(inout) :: self + end subroutine imhd_calc_all_quants + + subroutine imhd_save_all_quants(self) + class(imhd_zone_t), intent(inout) :: self + end subroutine imhd_save_all_quants + + subroutine imhd_eval_diss_power_density(self, x, ttype, spec, dpd) + class(imhd_zone_t), intent(in) :: self + real(dp), intent(in) :: x + integer, intent(in) :: ttype, spec + real(dp), intent(out) :: dpd(*) + write (*, '(a)') & + 'error: eval_diss_power_density() is not implemented for the imhd_zone' + end subroutine imhd_eval_diss_power_density + + subroutine imhd_eval_current_density(self, x, ttype, spec, comp, J) + class(imhd_zone_t), intent(in) :: self + real(dp), intent(in) :: x + integer, intent(in) :: ttype, spec, comp + real(dp), intent(out) :: J(*) + write (*, '(a)') & + 'error: eval_current_density() is not implemented for the imhd_zone' + end subroutine imhd_eval_current_density + + !> bind(C, name="calc_k_vals_") so that imhd.f90's existing + !> calc_k_vals_sub (an unchanged legacy Fortran external call) resolves + !> to this routine. Inlines the oracle's free `calc_k_vals` (a helper + !> with no other caller) directly, matching `calc_k_vals_`'s own + !> C++ body. `E` in the oracle's `kfac = E - kA*kA/(kp*kp)` is + !> constants.h's `const complex E(1.0, 0.0)` (just the complex + !> value 1+0i, unrelated to Euler's number or the elementary charge + !> `e` also defined in that header) - inlined here as cmplx_one. + subroutine calc_k_vals_(zone_ptr_handle, r, kt, kz, ks, kp, k2, kB, & + re_kA, im_kA, re_kfac, im_kfac) bind(C, name="calc_k_vals_") + integer(c_intptr_t), intent(in) :: zone_ptr_handle + real(c_double), intent(in) :: r + real(c_double), intent(out) :: kt, kz, ks, kp, k2, kB + real(c_double), intent(out) :: re_kA, im_kA, re_kfac, im_kfac + + class(zone_t), pointer :: zone + real(dp) :: Rb(5), B0, ht, hz, n0, Vz, VA + complex(dp) :: kA, kfac + + call handle_to_zone(zone_ptr_handle, zone) + + kt = real(zone%wd%m, dp)/r + kz = real(zone%wd%n, dp)/get_background_rtor() + k2 = kt*kt + kz*kz + + call eval_B0_ht_hz_n0_Vz(r, c_null_ptr, Rb) + B0 = Rb(1); ht = Rb(2); hz = Rb(3); n0 = Rb(4); Vz = Rb(5) + + ks = hz*kt - ht*kz + kp = ht*kt + hz*kz + + kB = kp*B0 + + VA = B0/sqrt(4.0_dp*pi*get_background_mass(0)*n0) + + kA = (zone%wd%olab - kz*Vz)/VA + + kfac = cmplx_one - kA*kA/(kp*kp) + + re_kA = real(kA, dp) + im_kA = aimag(kA) + re_kfac = real(kfac, dp) + im_kfac = aimag(kfac) + end subroutine calc_k_vals_ + +end module kilca_imhd_zone_m diff --git a/KiLCA/imhd/incompressible.cpp b/KiLCA/imhd/incompressible.cpp deleted file mode 100644 index 0c6a0e9d..00000000 --- a/KiLCA/imhd/incompressible.cpp +++ /dev/null @@ -1,539 +0,0 @@ -/*! \file incompressible.cpp - \brief The definitions of functions declared in incompressible.h. -*/ - -#include -#include -#include -#include -#include - -#include "fortnum.h" - -#include "constants.h" -#include "shared.h" -#include "eval_back.h" -#include "imhd_zone.h" -#include "incompressible.h" - -// GSL returned 0 (GSL_SUCCESS) from rhs/jac callbacks; keep the value so the -// callback contracts and the historical control flow stay byte-identical. -#ifndef GSL_SUCCESS -#define GSL_SUCCESS 0 -#endif - -/*******************************************************************/ - -int rhs_incompressible (double r, const double y[], double dy[], void *params) -{ -const imhd_zone *zone = (const imhd_zone *) params; - -complex A = Afunc_hi_inc (r, params); -complex B = Bfunc_hi_inc (r, params); - -//take A derivatives: -diff_params ps = {zone, 0}; - -double h = 1.0e-3, abserr; -double der_re, der_im; - -ps.part = 0; -fortnum_deriv_central (&Afunc_hi_inc_part, r, h, &der_re, &abserr, &ps); - -ps.part = 1; -fortnum_deriv_central (&Afunc_hi_inc_part, r, h, &der_im, &abserr, &ps); - -complex dA = der_re + I*der_im; - -complex f = y[0] + I*y[1]; //r*dzeta -complex g = y[2] + I*y[3]; //(r*dzeta)' - -complex df = g; -complex dg = -(dA*g + B*f)/A; - -//result: -dy[0] = real(df); -dy[1] = imag(df); -dy[2] = real(dg); -dy[3] = imag(dg); - -return GSL_SUCCESS; -} - -/*******************************************************************/ - -// fortnum_ode_rhs adapter: forwards to the historical rhs_incompressible, -// dropping the GSL return code (errors are signalled via the integrator). -static void rhs_incompressible_fn (double r, int n, const double y[], - double dydt[], void *ctx) -{ -(void) n; -rhs_incompressible (r, y, dydt, ctx); -} - -/*******************************************************************/ - -inline complex Afunc_hi_inc (double r, void *params) -{ -const imhd_zone *zone = (const imhd_zone *) params; - -int m = zone->wd->m; -double kz = (zone->wd->n)/(zone->sd->bs->rtor); - -complex omega2 = (zone->wd->olab)*(zone->wd->olab); - -double mdens; - -eval_mass_density (r, zone->bp, &mdens); - -double F = Ffunc (r, params); - -complex omega2_a = F*F/(4.0*pi*mdens); //omega^2_a - -double rk2 = r*(kz*kz + m*m/(r*r)); - -return mdens*(omega2 - omega2_a)/rk2; -} - -/*******************************************************************/ - -inline complex Bfunc_hi_inc (double r, void *params) -{ -const imhd_zone *zone = (const imhd_zone *) params; - -int m = zone->wd->m; -double kz = (zone->wd->n)/(zone->sd->bs->rtor); - -complex omega2 = (zone->wd->olab)*(zone->wd->olab); - -double mdens; - -eval_mass_density (r, zone->bp, &mdens); - -double F = Ffunc (r, params); - -double Bt; -eval_Bt (r, zone->bp, &Bt); - -complex omega2_a = F*F/(4.0*pi*mdens); - -double r3k2 = r*r*r*(kz*kz + m*m/(r*r)); - -complex t1 = - mdens*(omega2 - omega2_a)/r; - -complex t2 = 4.0*kz*kz*Bt*Bt/(4.0*pi*r3k2)*(omega2_a/(omega2 - omega2_a)); - -double t3, h = 1.0e-3, abserr; - -fortnum_deriv_central (&func_der, r, h, &t3, &abserr, params); - -return t1 + t2 + t3; -} - -/*******************************************************************/ - -inline double Afunc_hi_inc_part (double r, void *params) -{ -diff_params *dp = (diff_params *) params; - -complex A = Afunc_hi_inc (r, (void *)dp->zone); - -if (dp->part == 0) return real (A); -else return imag (A); -} - -/*******************************************************************/ - -inline double Bfunc_hi_inc_part (double r, void *params) -{ -diff_params *dp = (diff_params *) params; - -complex B = Bfunc_hi_inc (r, (void *)dp->zone); - -if (dp->part == 0) return real (B); -else return imag (B); -} - -/*******************************************************************/ - -inline double dBfunc_hi_inc_part (double r, void *params) -{ -diff_params *dp = (diff_params *) params; - -double h = 1.0e-3, abserr, der; - -fortnum_deriv_central (&Bfunc_hi_inc_part, r, h, &der, &abserr, dp); - -return der; -} - -/*******************************************************************/ - -inline double dAfunc_hi_inc_part (double r, void *params) -{ -diff_params *dp = (diff_params *) params; - -double h = 1.0e-3, abserr, der; - -fortnum_deriv_central (&Afunc_hi_inc_part, r, h, &der, &abserr, dp); - -return der; -} - -/*******************************************************************/ - -inline double ddAfunc_hi_inc_part (double r, void *params) -{ -diff_params *dp = (diff_params *) params; - -double h = 1.0e-3, abserr, der; - -fortnum_deriv_central (&dAfunc_hi_inc_part, r, h, &der, &abserr, dp); - -return der; -} - -/*******************************************************************/ - -inline double func_der (double r, void *params) -{ -const imhd_zone *zone = (const imhd_zone *) params; - -int m = zone->wd->m; -double kz = (zone->wd->n)/(zone->sd->bs->rtor); - -double G = Gfunc(r, params); - -double Bt; -eval_Bt (r, zone->bp, &Bt); - -double r2k2 = r*r*(kz*kz + m*m/(r*r)); - -return Bt*Bt/(4.0*pi*r*r) + 2.0*kz*Bt*G/(4.0*pi*r2k2); -} - -/*******************************************************************/ - -int jac_incompressible (double r, const double y[], double *dfdy, double dfdt[], void *params) -{ -const imhd_zone *zone = (const imhd_zone *) params; - -complex A = Afunc_hi_inc (r, params); -complex B = Bfunc_hi_inc (r, params); - -diff_params ps = {zone, 0}; - -ps.part = 0; -double dA_re = dAfunc_hi_inc_part (r, &ps); - -ps.part = 1; -double dA_im = dAfunc_hi_inc_part (r, &ps); - -complex dA = dA_re + I*dA_im; - -complex C = - dA/A, D = - B/A; - -double Cre = real(C), Cim = imag(C); -double Dre = real(D), Dim = imag(D); - -dfdy[0] = 0.0; dfdy[1] = 0.0; dfdy[2] = 1.0; dfdy[3] = 0.0; - -dfdy[4] = 0.0; dfdy[5] = 0.0; dfdy[6] = 1.0; dfdy[7] = 1.0; - -dfdy[8] = Dre; dfdy[9] = -Dim; dfdy[10] = Cre; dfdy[11] = -Cim; - -dfdy[12] = Dim; dfdy[13] = Dre; dfdy[14] = Cim; dfdy[15] = Cre; - -ps.part = 0; -double ddA_re = ddAfunc_hi_inc_part (r, &ps); - -ps.part = 1; -double ddA_im = ddAfunc_hi_inc_part (r, &ps); - -complex ddA = ddA_re + I*ddA_im; - -ps.part = 0; -double dB_re = dBfunc_hi_inc_part (r, &ps); - -ps.part = 1; -double dB_im = dBfunc_hi_inc_part (r, &ps); - -complex dB = dB_re + I*dB_im; - -complex dC = - (ddA*A - dA*dA)/A/A; - -complex dD = - (dB*A - B*dA)/A/A; - -double dCre = real(dC), dCim = imag(dC); -double dDre = real(dD), dDim = imag(dD); - -dfdt[0] = 0.0; -dfdt[1] = 0.0; -dfdt[2] = dDre*y[0] - dDim*y[1] + dCre*y[2] - dCim*y[3]; -dfdt[3] = dDim*y[0] + dDre*y[1] + dCim*y[2] + dCre*y[3]; - -return GSL_SUCCESS; -} - -/*******************************************************************/ - -void imhd_zone::calculate_basis_incompressible_gsl (void) -{ -//for tests only, use general cvode version! - -if (!(bc1 == BOUNDARY_CENTER || bc2 == BOUNDARY_IDEALWALL)) -{ - fprintf (stdout, "\nimhd::calculate_basis_incompressible_gsl: zone=%d: error!", index); - exit (1); -} - -const int Neq = 4; //2 real eqs, 2 imag eqs for (r*zeta), (r*zeta)' - -double t, tfinal; - -double y[4]; - -int ind; - -if (bc1 == BOUNDARY_CENTER) -{ - t = r1; - tfinal = r2; - - //y start for integrator - y[0] = pow (t, abs(wd->m)); - y[1] = 0.0; - y[2] = abs(wd->m)*pow (t, abs(wd->m)-1); - y[3] = 0.0; - - ind = 0; //index of a fundamental solution which is regular at the boundary -} -else if (bc2 == BOUNDARY_IDEALWALL) -{ - t = r2; - tfinal = r1; - - y[0] = 0.0; - y[1] = 0.0; - y[2] = 1.0; - y[3] = 0.0; - - ind = 0; //index of a fundamental solution which is regular at the boundary -} -else -{ - fprintf (stdout, "\nimhd::calculate_basis_incompressible_gsl: error!"); - exit (1); -} - -size_t iter; - -//arrays: -double *grid = new double[max_dim]; - -double *syst = new double[max_dim*Nwaves*Ncomps*2]; - -// Evolve continuously with the GSL-faithful rk8pd stepper, recording every -// accepted step as the radial grid. This mirrors the original -// gsl_odeiv_evolve_apply loop under gsl_odeiv_control_y_new(eps_abs, eps_rel): -// the integrator carried its adaptive step across the interval and the loop -// stored (t, y) after each accepted step. The dop853 path used a different -// 8(7) error norm and accepted-step mesh, drifting the linear response from -// the golden. The starting step matches the golden: h0 = 1e-6 in the -// integration direction. -double h0 = (1.0e-6)*signum(tfinal-t); - -void *ode = fortnum_rk8pd_create (&rhs_incompressible_fn, Neq, h0, - eps_abs, eps_rel, 100000, this); - -if (!ode) -{ - fprintf (stderr, "\ncalculate_basis_incompressible_gsl: failed to create ODE evolver"); - exit (1); -} - -//initial point: -iter = 0; -grid[iter] = t; - -syst[ib(iter, ind, 6, 0)] = y[0]; -syst[ib(iter, ind, 6, 1)] = y[1]; -syst[ib(iter, ind, 7, 0)] = y[2]; -syst[ib(iter, ind, 7, 1)] = y[3]; - -state_to_EB_incompressible (grid[iter], syst+ib(iter, ind, 6, 0), syst+ib(iter, ind, 0, 0)); - -while (t != tfinal) -{ - int ode_status = fortnum_rk8pd_step_to (ode, &t, tfinal, y); - - if (ode_status != FORTNUM_OK) - { - fprintf (stderr, "\ncalculate_basis_incompressible_gsl: ODE solver failed at r = %le", t); - exit (1); - } - - //store values: - iter++; - grid[iter] = t; - - syst[ib(iter, ind, 6, 0)] = y[0]; - syst[ib(iter, ind, 6, 1)] = y[1]; - syst[ib(iter, ind, 7, 0)] = y[2]; - syst[ib(iter, ind, 7, 1)] = y[3]; - - state_to_EB_incompressible (grid[iter], syst+ib(iter, ind, 6, 0), syst+ib(iter, ind, 0, 0)); - - if (iter == max_dim-1) - { - fprintf (stderr, "\nMaximum allowed iteration number is reached: iter=%d r=%le", (int)iter, t); - exit (1); - } -} - -fortnum_rk8pd_destroy (ode); - -dim = iter + 1; - -//zone class data allocation: -r = new double[dim]; - -int len = dim*Nwaves*Ncomps*2; - -basis = new double[len]; - -for (int i=0; i-1; j--) - { - r[k] = grid[j]; - - for (int comp=0; comp rzeta = state[0] + I*state[1]; //(r*zeta) -complex drzeta = state[2] + I*state[3]; //(r*zeta)' - -complex zeta_r = rzeta/r; -complex dzeta_r = (drzeta - zeta_r)/r; - -//wave: -double kt = (wd->m)/r; -double kz = (wd->n)/(sd->bs->rtor); -double k0k0 = kt*kt + kz*kz; - -//background: -double R[4]; - -eval_Bt_dBt_Bz_dBz (r, bp, R); - -double B0t = R[0]; -double dB0t = R[1]; -double B0z = R[2]; -double dB0z = R[3]; - -double F = kt*B0t + kz*B0z; //double G = kt*B0z - kz*B0t; - -double rho; eval_mass_density (r, bp, &rho); - -complex tB = 2.0*I*kz*B0t/(4.0*pi*r); - -complex omega2 = (wd->olab)*(wd->olab); - -complex omegaa2 = F*F/(4.0*pi*rho); - -complex comfac1 = zeta_r*F*tB/(k0k0*rho*(omega2-omegaa2)); - -complex comfac2 = drzeta*I/(r*k0k0); - -complex zeta_t = - comfac1*kz + comfac2*kt; -complex zeta_z = comfac1*kt + comfac2*kz; - -complex alpha = zeta_t*B0z - zeta_z*B0t; - -//Br: -complex Br = I*F*zeta_r; - -//Bt: -complex Bt = - (dzeta_r*B0t + zeta_r*dB0t) + I*kz*alpha; - -//Bz: -complex Bz = - (drzeta*B0z + rzeta*dB0z)/r - I*kt*alpha; - -//Er: -complex Er = O; - -//Et: -complex Et = O; - -//Ez: -complex Ez = O; - -//setup output values: -EB[0] = real (Er); EB[1] = imag (Er); -EB[2] = real (Et); EB[3] = imag (Et); -EB[4] = real (Ez); EB[5] = imag (Ez); -EB[6] = real (Br); EB[7] = imag (Br); -EB[8] = real (Bt); EB[9] = imag (Bt); -EB[10] = real (Bz); EB[11] = imag (Bz); -EB[12] = real (rzeta); EB[13] = imag (rzeta); -EB[14] = real (drzeta); EB[15] = imag (drzeta); - -//check for divergence: -double divzeta = abs(drzeta/r + I*(kt*zeta_t + kz*zeta_z)); - -double tst = abs(drzeta/r) + abs(kt*zeta_t) + abs(kz*zeta_z); - -if (divzeta/tst > 1.0e-15) -{ - fprintf (stdout, "\nimhd_zone::state_to_EB_incompressible: warning: r = %le\t|divzeta| = %le\ttst = %le", r, divzeta, tst); -} -} - -/*******************************************************************/ diff --git a/KiLCA/imhd/incompressible.h b/KiLCA/imhd/incompressible.h deleted file mode 100644 index c2eb162e..00000000 --- a/KiLCA/imhd/incompressible.h +++ /dev/null @@ -1,51 +0,0 @@ -/*! \file incompressible.h - \brief The declarations of functions implementing incompressible flowless MHD equations. -*/ - -#ifndef IMHD_INCOMPRESSIBLE_INCLUDE - -#define IMHD_INCOMPRESSIBLE_INCLUDE - -#include -#include "constants.h" -#include "imhd_zone.h" - -/*******************************************************************/ - -struct diff_params -{ - const imhd_zone *zone; //pointer to imhd object - int part; //real or imag -}; - -/*******************************************************************/ - -int rhs_incompressible (double r, const double y[], double f[], void *params); - -int jac_incompressible (double t, const double y[], double *dfdy, double dfdt[], void *params); - -inline complex Afunc_hi_inc (double r, void *params); - -inline double Afunc_hi_inc_part(double r, void *params); - -inline double dAfunc_hi_inc_part(double r, void *params); - -inline double ddAfunc_hi_inc_part(double r, void *params); - -inline complex Bfunc_hi_inc (double r, void *params); - -inline double Bfunc_hi_inc_part(double r, void *params); - -inline double dBfunc_hi_inc_part(double r, void *params); - -inline double func_der (double r, void *params); - -/*******************************************************************/ - -extern "C" -{ -} - -/*******************************************************************/ - -#endif diff --git a/KiLCA/imhd/incompressible_m.f90 b/KiLCA/imhd/incompressible_m.f90 new file mode 100644 index 00000000..0600a3bb --- /dev/null +++ b/KiLCA/imhd/incompressible_m.f90 @@ -0,0 +1,451 @@ +!> Incompressible, flowless ideal-MHD basis calculation for imhd_zone version 0 +!> (formerly incompressible.{h,cpp}). The "_gsl" suffix in the oracle's +!> function names is stale: the C++ already used fortnum's callback-based +!> rk8pd/deriv_central, not GSL. This translation upgrades those calls to +!> fortnum's native Fortran interfaces (kilca_background_data_m's own +!> calculate_equilibrium already set this precedent for the same rk8pd +!> stepper). +!> +!> Ffunc/Gfunc are defined here (rather than in kilca_imhd_zone_m, where the +!> C++ oracle keeps them) because kilca_compressible_flow_m also needs them +!> and kilca_imhd_zone_m needs kilca_compressible_flow_m's +!> calculate_basis_flow: putting Ffunc/Gfunc in kilca_imhd_zone_m would make +!> that module and this one depend on each other in both directions, which +!> Fortran's `use` graph cannot express. All routines here take a bare +!> class(zone_t) since neither Ffunc/Gfunc nor the basis calculation touch +!> anything imhd_zone_t adds over the base type (imhd_zone has no data +!> members of its own in the C++ oracle either). +module kilca_incompressible_m + use, intrinsic :: iso_c_binding, only: c_double, c_null_ptr + use constants, only: dp, pi + use kilca_zone_m, only: zone_t, BOUNDARY_CENTER, BOUNDARY_IDEALWALL + use kilca_background_data_m, only: eval_Bt_Bz, eval_Bt, eval_mass_density, & + eval_Bt_dBt_Bz_dBz + use fortnum_status, only: fortnum_status_t, FORTNUM_OK + use fortnum_ode_rk8pd, only: rk8pd_state_t, rk8pd_evolve_init, rk8pd_evolve_apply + use fortnum_multiroot, only: deriv_central + implicit none + private + + public :: zone_ctx_t, zone_part_ctx_t + public :: Ffunc, Gfunc, signum + public :: calculate_basis_incompressible, state_to_EB_incompressible + public :: rhs_incompressible + + complex(dp), parameter :: cmplx_zero = (0.0_dp, 0.0_dp) + complex(dp), parameter :: cmplx_i = (0.0_dp, 1.0_dp) + real(dp), parameter :: deriv_h = 1.0e-3_dp + + !> deriv_central/rk8pd callback context: the zone being integrated. + type :: zone_ctx_t + class(zone_t), pointer :: zone => null() + end type zone_ctx_t + + !> deriv_central context for the real/imag parts of a complex coefficient + !> function (matches the oracle's diff_params). + type :: zone_part_ctx_t + class(zone_t), pointer :: zone => null() + integer :: part = 0 + end type zone_part_ctx_t + + interface + function get_background_rtor() bind(C, name="get_background_rtor_") result(rtor) + import :: c_double + real(c_double) :: rtor + end function get_background_rtor + end interface + + external :: normalize_imhd_basis + +contains + + real(dp) function Ffunc(zone, r) result(F) + class(zone_t), pointer, intent(in) :: zone + real(dp), intent(in) :: r + real(dp) :: kt, kz, BtBz(2) + kt = real(zone%wd%m, dp)/r + kz = real(zone%wd%n, dp)/get_background_rtor() + call eval_Bt_Bz(r, c_null_ptr, BtBz) + F = kt*BtBz(1) + kz*BtBz(2) + end function Ffunc + + real(dp) function Gfunc(zone, r) result(G) + class(zone_t), pointer, intent(in) :: zone + real(dp), intent(in) :: r + real(dp) :: kt, kz, BtBz(2) + kt = real(zone%wd%m, dp)/r + kz = real(zone%wd%n, dp)/get_background_rtor() + call eval_Bt_Bz(r, c_null_ptr, BtBz) + G = kt*BtBz(2) - kz*BtBz(1) + end function Gfunc + + integer function signum(x) result(s) + real(dp), intent(in) :: x + if (x < 0.0_dp) then + s = -1 + else if (x == 0.0_dp) then + s = 0 + else + s = 1 + end if + end function signum + + complex(dp) function Afunc_hi_inc(zone, r) result(A) + class(zone_t), pointer, intent(in) :: zone + real(dp), intent(in) :: r + real(dp) :: kz, mdens(1), F, rk2 + complex(dp) :: omega2, omega2_a + + kz = real(zone%wd%n, dp)/get_background_rtor() + omega2 = zone%wd%olab*zone%wd%olab + call eval_mass_density(r, c_null_ptr, mdens) + F = Ffunc(zone, r) + omega2_a = cmplx(F*F/(4.0_dp*pi*mdens(1)), 0.0_dp, dp) + rk2 = r*(kz*kz + real(zone%wd%m, dp)**2/(r*r)) + A = mdens(1)*(omega2 - omega2_a)/rk2 + end function Afunc_hi_inc + + complex(dp) function Bfunc_hi_inc(zone, r) result(B) + class(zone_t), pointer, intent(in) :: zone + real(dp), intent(in) :: r + real(dp) :: kz, mdens(1), F, Bt(1), r3k2, t3, abserr + complex(dp) :: omega2, omega2_a, t1, t2 + type(zone_ctx_t) :: ctx + type(fortnum_status_t) :: status + + kz = real(zone%wd%n, dp)/get_background_rtor() + omega2 = zone%wd%olab*zone%wd%olab + call eval_mass_density(r, c_null_ptr, mdens) + F = Ffunc(zone, r) + call eval_Bt(r, c_null_ptr, Bt) + + omega2_a = cmplx(F*F/(4.0_dp*pi*mdens(1)), 0.0_dp, dp) + r3k2 = r*r*r*(kz*kz + real(zone%wd%m, dp)**2/(r*r)) + + t1 = -mdens(1)*(omega2 - omega2_a)/r + t2 = 4.0_dp*kz*kz*Bt(1)*Bt(1)/(4.0_dp*pi*r3k2)*(omega2_a/(omega2 - omega2_a)) + + ctx%zone => zone + call deriv_central(func_der, r, deriv_h, t3, abserr, status, ctx) + + B = t1 + t2 + t3 + end function Bfunc_hi_inc + + real(dp) function Afunc_hi_inc_part(r, ctx) result(res) + real(dp), intent(in) :: r + class(*), intent(in), optional :: ctx + complex(dp) :: A + select type (ctx) + type is (zone_part_ctx_t) + A = Afunc_hi_inc(ctx%zone, r) + if (ctx%part == 0) then + res = real(A, dp) + else + res = aimag(A) + end if + end select + end function Afunc_hi_inc_part + + real(dp) function Bfunc_hi_inc_part(r, ctx) result(res) + real(dp), intent(in) :: r + class(*), intent(in), optional :: ctx + complex(dp) :: B + select type (ctx) + type is (zone_part_ctx_t) + B = Bfunc_hi_inc(ctx%zone, r) + if (ctx%part == 0) then + res = real(B, dp) + else + res = aimag(B) + end if + end select + end function Bfunc_hi_inc_part + + real(dp) function dAfunc_hi_inc_part(r, ctx) result(der) + real(dp), intent(in) :: r + class(*), intent(in), optional :: ctx + real(dp) :: abserr + type(fortnum_status_t) :: status + call deriv_central(Afunc_hi_inc_part, r, deriv_h, der, abserr, status, ctx) + end function dAfunc_hi_inc_part + + real(dp) function ddAfunc_hi_inc_part(r, ctx) result(der) + real(dp), intent(in) :: r + class(*), intent(in), optional :: ctx + real(dp) :: abserr + type(fortnum_status_t) :: status + call deriv_central(dAfunc_hi_inc_part, r, deriv_h, der, abserr, status, ctx) + end function ddAfunc_hi_inc_part + + real(dp) function dBfunc_hi_inc_part(r, ctx) result(der) + real(dp), intent(in) :: r + class(*), intent(in), optional :: ctx + real(dp) :: abserr + type(fortnum_status_t) :: status + call deriv_central(Bfunc_hi_inc_part, r, deriv_h, der, abserr, status, ctx) + end function dBfunc_hi_inc_part + + real(dp) function func_der(r, ctx) result(res) + real(dp), intent(in) :: r + class(*), intent(in), optional :: ctx + real(dp) :: kz, G, Bt(1), r2k2 + select type (ctx) + type is (zone_ctx_t) + kz = real(ctx%zone%wd%n, dp)/get_background_rtor() + G = Gfunc(ctx%zone, r) + call eval_Bt(r, c_null_ptr, Bt) + r2k2 = r*r*(kz*kz + real(ctx%zone%wd%m, dp)**2/(r*r)) + res = Bt(1)*Bt(1)/(4.0_dp*pi*r*r) + 2.0_dp*kz*Bt(1)*G/(4.0_dp*pi*r2k2) + end select + end function func_der + + !> Folds the oracle's rhs_incompressible (GSL-style int return) and its + !> rhs_incompressible_fn fortnum_ode_rhs adapter into one ode_rhs_t-shaped + !> routine; the GSL_SUCCESS return code carried no information once the + !> adapter dropped it. + subroutine rhs_incompressible(r, y, dydt, ctx) + real(dp), intent(in) :: r + real(dp), intent(in) :: y(:) + real(dp), intent(out) :: dydt(:) + class(*), intent(in), optional :: ctx + + class(zone_t), pointer :: zone + complex(dp) :: A, B, dA, f, g, df, dg + real(dp) :: der_re, der_im, abserr + type(fortnum_status_t) :: status + type(zone_part_ctx_t) :: dctx + + zone => null() + select type (ctx) + type is (zone_ctx_t) + zone => ctx%zone + end select + + A = Afunc_hi_inc(zone, r) + B = Bfunc_hi_inc(zone, r) + + dctx%zone => zone + + dctx%part = 0 + call deriv_central(Afunc_hi_inc_part, r, deriv_h, der_re, abserr, status, dctx) + dctx%part = 1 + call deriv_central(Afunc_hi_inc_part, r, deriv_h, der_im, abserr, status, dctx) + dA = cmplx(der_re, der_im, dp) + + f = cmplx(y(1), y(2), dp) ! r*zeta + g = cmplx(y(3), y(4), dp) ! (r*zeta)' + + df = g + dg = -(dA*g + B*f)/A + + dydt(1) = real(df, dp) + dydt(2) = aimag(df) + dydt(3) = real(dg, dp) + dydt(4) = aimag(dg) + end subroutine rhs_incompressible + + !> Mirrors imhd_zone::calculate_basis_incompressible_gsl exactly, + !> including the magic numbers (h0 = 1e-6 in the integration direction, + !> max_steps = 100000) and the continuous rk8pd evolve recording every + !> accepted step (single_step=.true., matching the GSL-faithful stepper + !> driving fortnum_rk8pd_step_to in the oracle). + subroutine calculate_basis_incompressible(self) + class(zone_t), intent(inout), target :: self + + class(zone_t), pointer :: zone_ptr + integer, parameter :: Neq = 4 + real(dp) :: t, tfinal + real(dp) :: y(Neq) + integer :: ind + real(dp), allocatable :: grid(:) + complex(dp), allocatable :: syst(:, :, :) + real(dp) :: h0 + type(rk8pd_state_t) :: ode_state + type(fortnum_status_t) :: status + type(zone_ctx_t) :: ctx + integer :: nfev, iter, j, k + complex(dp) :: EB(8) + logical :: valid_bc + + valid_bc = (self%bc1 == BOUNDARY_CENTER .or. self%bc2 == BOUNDARY_IDEALWALL) + if (.not. valid_bc) then + write (*, '(a,i0,a)') & + 'imhd::calculate_basis_incompressible_gsl: zone=', self%index, & + ': error!' + stop 1 + end if + + zone_ptr => self + ctx%zone => zone_ptr + + if (self%bc1 == BOUNDARY_CENTER) then + t = self%r1 + tfinal = self%r2 + + y(1) = t**abs(self%wd%m) + y(2) = 0.0_dp + y(3) = real(abs(self%wd%m), dp)*t**(abs(self%wd%m) - 1) + y(4) = 0.0_dp + + ind = 0 + else if (self%bc2 == BOUNDARY_IDEALWALL) then + t = self%r2 + tfinal = self%r1 + + y(1) = 0.0_dp + y(2) = 0.0_dp + y(3) = 1.0_dp + y(4) = 0.0_dp + + ind = 0 + else + write (*, '(a)') 'imhd::calculate_basis_incompressible_gsl: error!' + stop 1 + end if + + allocate (grid(self%max_dim)) + allocate (syst(self%Ncomps, self%Nwaves, self%max_dim)) + syst = cmplx_zero + + h0 = 1.0e-6_dp*real(signum(tfinal - t), dp) + + call rk8pd_evolve_init(ode_state, Neq, h0, status) + if (status%code /= FORTNUM_OK) then + write (*, '(a)') & + 'calculate_basis_incompressible_gsl: failed to create ODE evolver' + stop 1 + end if + + iter = 1 + grid(iter) = t + call state_to_EB_incompressible(zone_ptr, grid(iter), y, EB) + syst(:, ind + 1, iter) = EB + + nfev = 0 + do while (t /= tfinal) + call rk8pd_evolve_apply(rhs_incompressible, ode_state, t, tfinal, y, & + self%eps_abs, self%eps_rel, 100000, nfev, status, ctx, & + single_step=.true.) + + if (status%code /= FORTNUM_OK) then + write (*, '(a,es12.4e3)') & + 'calculate_basis_incompressible_gsl: ODE solver failed at r = ', t + stop 1 + end if + + iter = iter + 1 + grid(iter) = t + call state_to_EB_incompressible(zone_ptr, grid(iter), y, EB) + syst(:, ind + 1, iter) = EB + + if (iter == self%max_dim) then + write (*, '(a,i0,a,es12.4e3)') & + 'Maximum allowed iteration number is reached: iter=', iter, ' r=', t + stop 1 + end if + end do + + self%dim = iter + + if (allocated(self%r)) deallocate (self%r) + allocate (self%r(self%dim)) + if (allocated(self%basis)) deallocate (self%basis) + allocate (self%basis(self%Ncomps, self%Nwaves, self%dim)) + self%basis = cmplx_zero + + if (self%bc1 == BOUNDARY_CENTER) then + do j = 1, self%dim + self%r(j) = grid(j) + self%basis(:, ind + 1, j) = syst(:, ind + 1, j) + end do + call normalize_imhd_basis(self%Ncomps, self%Nwaves, self%dim, self%basis, & + ind, self%dim - 1) + else if (self%bc2 == BOUNDARY_IDEALWALL) then + k = 1 + do j = self%dim, 1, -1 + self%r(k) = grid(j) + self%basis(:, ind + 1, k) = syst(:, ind + 1, j) + k = k + 1 + end do + call normalize_imhd_basis(self%Ncomps, self%Nwaves, self%dim, self%basis, & + ind, 0) + else + write (*, '(a)') 'imhd::calculate_basis_incompressible_gsl: error!' + stop 1 + end if + + deallocate (grid, syst) + end subroutine calculate_basis_incompressible + + !> Mirrors imhd_zone::state_to_EB_incompressible exactly. state holds + !> (r*zeta), (r*zeta)' as (re, im) pairs; EB returns Er, Et, Ez, Br, Bt, + !> Bz, (r*zeta), (r*zeta)' as genuine complex values (the oracle's flat + !> 16-double EB[] is just the same 8 complex values written as re/im + !> pairs - this routine has no external/bind(C) caller, so the native + !> complex representation is used directly instead). + subroutine state_to_EB_incompressible(zone, r, state, EB) + class(zone_t), pointer, intent(in) :: zone + real(dp), intent(in) :: r + real(dp), intent(in) :: state(4) + complex(dp), intent(out) :: EB(8) + + complex(dp) :: rzeta, drzeta, zeta_r, dzeta_r + real(dp) :: kt, kz, k0k0 + real(dp) :: Rb(4), B0t, dB0t, B0z, dB0z, F, rho(1) + complex(dp) :: tB, omega2, omegaa2, comfac1, comfac2, zeta_t, zeta_z, alpha + complex(dp) :: Br, Bt, Bz, Er, Et, Ez + real(dp) :: divzeta, tst + + rzeta = cmplx(state(1), state(2), dp) + drzeta = cmplx(state(3), state(4), dp) + + zeta_r = rzeta/r + dzeta_r = (drzeta - zeta_r)/r + + kt = real(zone%wd%m, dp)/r + kz = real(zone%wd%n, dp)/get_background_rtor() + k0k0 = kt*kt + kz*kz + + call eval_Bt_dBt_Bz_dBz(r, c_null_ptr, Rb) + B0t = Rb(1); dB0t = Rb(2); B0z = Rb(3); dB0z = Rb(4) + + F = kt*B0t + kz*B0z + + call eval_mass_density(r, c_null_ptr, rho) + + tB = 2.0_dp*cmplx_i*kz*B0t/(4.0_dp*pi*r) + + omega2 = zone%wd%olab*zone%wd%olab + omegaa2 = cmplx(F*F/(4.0_dp*pi*rho(1)), 0.0_dp, dp) + + comfac1 = zeta_r*F*tB/(k0k0*rho(1)*(omega2 - omegaa2)) + comfac2 = drzeta*cmplx_i/(r*k0k0) + + zeta_t = -comfac1*kz + comfac2*kt + zeta_z = comfac1*kt + comfac2*kz + + alpha = zeta_t*B0z - zeta_z*B0t + + Br = cmplx_i*F*zeta_r + Bt = -(dzeta_r*B0t + zeta_r*dB0t) + cmplx_i*kz*alpha + Bz = -(drzeta*B0z + rzeta*dB0z)/r - cmplx_i*kt*alpha + + Er = cmplx_zero + Et = cmplx_zero + Ez = cmplx_zero + + EB(1) = Er; EB(2) = Et; EB(3) = Ez + EB(4) = Br; EB(5) = Bt; EB(6) = Bz + EB(7) = rzeta; EB(8) = drzeta + + divzeta = abs(drzeta/r + cmplx_i*(kt*zeta_t + kz*zeta_z)) + tst = abs(drzeta/r) + abs(kt*zeta_t) + abs(kz*zeta_z) + + if (divzeta/tst > 1.0e-15_dp) then + write (*, '(a,es12.4e3,a,es12.4e3,a,es12.4e3)') & + 'imhd_zone::state_to_EB_incompressible: warning: r = ', r, & + char(9)//'|divzeta| = ', divzeta, char(9)//'tst = ', tst + end if + end subroutine state_to_EB_incompressible + +end module kilca_incompressible_m diff --git a/KiLCA/interface/fill_array.cpp b/KiLCA/interface/fill_array.cpp deleted file mode 100644 index 7040f4bc..00000000 --- a/KiLCA/interface/fill_array.cpp +++ /dev/null @@ -1,37 +0,0 @@ -#include - -extern "C" -{ -/********************************************************************/ - -void fill_array_(double ** arr, int * n1, int * n2, int * n3) -{ -int m1 = 5, m2 = 10, m3 = 15; - -double * a = new double[2*m1*m2*m3]; - -for (int i1 = 0; i1 < m1; ++i1) -{ - for (int i2 = 0; i2 < m2; ++i2) - { - for (int i3 = 0; i3 < m3; ++i3) - { - a[2*(i1*m3*m2 + i2*m3 + i3) + 0] = (i1*1000 + i2 * 100 + i3); - a[2*(i1*m3*m2 + i2*m3 + i3) + 1] = - (i1*1000 + i2 * 100 + i3); - - std::cout << "(" << i1 << ","<< i2 << ","<< i3 << ")\t" << 2*(i1*m3*m2 + i2*m3 + i3) << "\t" << a[2*(i1*m3*m2 + i2*m3 + i3) + 0] << "\t"<< a[2*(i1*m3*m2 + i2*m3 + i3) + 1] << "\n"; - } - } -} - -//std::cout << a; - -*arr = a; - -*n1 = m1; -*n2 = m2; -*n3 = m3; -} - -/********************************************************************/ -} diff --git a/KiLCA/interface/wave_code_interface.cpp b/KiLCA/interface/wave_code_interface.cpp deleted file mode 100644 index 188458e8..00000000 --- a/KiLCA/interface/wave_code_interface.cpp +++ /dev/null @@ -1,478 +0,0 @@ -/*! \file - \brief The definitions of functions declared in wave_code_interface.h. -*/ - -#include -#include -#include -#include -#include - -#include "core.h" -#include "mode.h" -#include "background.h" -#include "transforms.h" -#include "spline.h" -#include "flre_zone.h" -#include "wave_code_interface.h" - -/*******************************************************************/ - -void calc_wave_code_data_ (core_data ** cdptr, char const * run_path, int * pathlength) -{ - //!The function computes wave fields and other quantities which migth be obtained by subsequent calls of other get_* () interface functions - //gets path to the project - char * path = new char[1024]; - memcpy (path, run_path, *pathlength); - path[*pathlength] = '\0'; //end of string symbol - - if (path[strlen(path)-1] != '/') strcat(path, "/"); - - //!Allocates core data structure containing pointers to all important code data - core_data * cd = new core_data (path); - set_core_data_in_core_module_ (&cd); - *cdptr = cd; - - cd->calc_and_set_mode_independent_core_data (); - cd->calc_and_set_mode_dependent_core_data_antenna_interface (); - - delete [] path; -} - -/*******************************************************************/ - -void calc_wave_code_data_for_mode_ (core_data ** cdptr, char const * run_path, int * pathlength, int * m, int * n) -{ - //!The function computes wave fields and other quantities which migth be obtained by subsequent calls of other get_* () interface functions - //gets path to the project - char * path = new char[1024]; - memcpy (path, run_path, *pathlength); - path[*pathlength] = '\0'; //end of string symbol - if (path[strlen(path)-1] != '/') strcat(path, "/"); - - //!Allocates core data structure containing pointers to all important code data - core_data * cd = new core_data (path); - set_core_data_in_core_module_ (&cd); - *cdptr = cd; - - cd->calc_and_set_mode_independent_core_data (); - - cd->calc_and_set_mode_dependent_core_data_antenna_interface (*m, *n); - - delete [] path; -} - -/*******************************************************************/ - -void clear_wave_code_data_ (core_data ** cdptr) -{ -//!The functions deletes all wave code data -delete *cdptr; -} - -/*******************************************************************/ - -void get_basic_background_profiles_from_wave_code_ (core_data ** cdptr, int * dim_r, double * r, - double * q, double * n, - double * Ti, double * Te, - double * Vth, double * Vz, double * dPhi0) -{ -core_data * cd = *cdptr; - -cd->bp->interp_basic_background_profiles_in_lab_frame (*dim_r, r, q, n, Ti, Te, Vth, Vz, dPhi0); -} - -/*******************************************************************/ - -void get_wave_vectors_from_wave_code_ (core_data ** cdptr, int * dim_r, double * r, - int * m, int * n, double * ks, double * kp) -{ -core_data *cd = *cdptr; - -for (int i=0; i<*dim_r; i++) -{ - double kth = (*m)/r[i]; - double kz = (*n)/(cd->sd->bs->rtor); - - spline_eval_ (cd->bp->sid, 1, r+i, 0, 0, cd->bp->i_hth, cd->bp->i_hz, cd->bp->R); - - double ht = cd->bp->R[0]; - double hz = cd->bp->R[1]; - - kp[i] = ht*kth + hz*kz; - ks[i] = hz*kth - ht*kz; -} -} - -/*******************************************************************/ - -void get_background_magnetic_fields_from_wave_code_ (core_data ** cdptr, int * dim_r, double * r, - double * Bt, double * Bz, double * B0) -{ -core_data * cd = *cdptr; - -for (int i=0; i<*dim_r; i++) -{ - spline_eval_ (cd->bp->sid, 1, r+i, 0, 0, cd->bp->i_Bth, cd->bp->i_B, cd->bp->R); - - Bt[i] = cd->bp->R[0]; - Bz[i] = cd->bp->R[1]; - B0[i] = cd->bp->R[2]; -} -} - -/*******************************************************************/ - -void get_collision_frequences_from_wave_code_ (core_data ** cdptr, int * dim_r, double * r, - double * nui, double * nue) -{ -core_data * cd = *cdptr; - -for (int i=0; i<*dim_r; i++) -{ - spline_eval_ (cd->bp->sid, 1, r+i, 0, 0, cd->bp->i_nu[0], cd->bp->i_nu[0], nui+i); - spline_eval_ (cd->bp->sid, 1, r+i, 0, 0, cd->bp->i_nu[1], cd->bp->i_nu[1], nue+i); -} -} - -/*******************************************************************/ - -void get_wave_fields_from_wave_code_ (core_data ** cdptr, int * dim_r, double * r, - int * m, int * n, - double * Er, double * Es, double * Ep, - double * Et, double * Ez, - double * Br, double * Bs, double * Bp, - double * Bt, double * Bz) -{ -core_data *cd = *cdptr; - -//search for mode index -int num = -1; - -for (int i=0; idim; i++) -{ - if (cd->mda[i]->wd->m == *m && cd->mda[i]->wd->n == *n) - { - num = i; - break; - } -} - -if (num == -1) -{ - fprintf (stdout, "\nwarning: get_wave_fields_from_wave_code: (%d, %d) mode is not in the spectrum.", *m, *n); - return; -} - -for (int i=0; i<*dim_r; i++) -{ - complex EBcyl[6]; - complex EBrsp[6]; - - cd->mda[num]->eval_EB_fields (r[i], EBcyl); - - transform_EB_from_cyl_to_rsp (cd->bp, r[i], EBcyl, EBrsp); - - //copy values to fortran complex arrays passed as C double arrays: - int ind = 2*i; - - Er[ind+0] = real (EBcyl[0]); - Er[ind+1] = imag (EBcyl[0]); - - Es[ind+0] = real (EBrsp[1]); - Es[ind+1] = imag (EBrsp[1]); - - Ep[ind+0] = real (EBrsp[2]); - Ep[ind+1] = imag (EBrsp[2]); - - Et[ind+0] = real (EBcyl[1]); - Et[ind+1] = imag (EBcyl[1]); - - Ez[ind+0] = real (EBcyl[2]); - Ez[ind+1] = imag (EBcyl[2]); - - Br[ind+0] = real (EBcyl[3]); - Br[ind+1] = imag (EBcyl[3]); - - Bs[ind+0] = real (EBrsp[4]); - Bs[ind+1] = imag (EBrsp[4]); - - Bp[ind+0] = real (EBrsp[5]); - Bp[ind+1] = imag (EBrsp[5]); - - Bt[ind+0] = real (EBcyl[4]); - Bt[ind+1] = imag (EBcyl[4]); - - Bz[ind+0] = real (EBcyl[5]); - Bz[ind+1] = imag (EBcyl[5]); -} -} - -/*******************************************************************/ - -void get_diss_power_density_from_wave_code_ (core_data ** cdptr, int * dim_r, double * r, - int * m, int * n, - int * type, int * spec, double * pdis) -{ -core_data *cd = *cdptr; - -//search for mode index -int num = -1; - -for (int i=0; idim; i++) -{ - if (cd->mda[i]->wd->m == *m && cd->mda[i]->wd->n == *n) - { - num = i; - break; - } -} - -if (num == -1) -{ - fprintf (stdout, "\nwarning: get_wave_fields_from_wave_code: (%d, %d) mode is not in the spectrum.", *m, *n); - return; -} - -for (int i=0; i<*dim_r; i++) -{ - cd->mda[num]->eval_diss_power_density (r[i], *type, *spec, pdis+i); -} -} - -/*******************************************************************/ - -void get_antenna_spectrum_dim_ (core_data ** cdptr, int * dim_mn) -{ -core_data *cd = *cdptr; - -*dim_mn = cd->dim; -} - -/*******************************************************************/ - -void get_antenna_spectrum_numbers_ (core_data ** cdptr, int * dim_mn, int * m_vals, int * n_vals) -{ -core_data *cd = *cdptr; - -if (*dim_mn != cd->dim) -{ - fprintf (stdout, "\nwarning: get_antenna_spectrum_numbers: spectrum dimensions must match"); - return; -} - -for (int i=0; idim; i++) -{ - m_vals[i] = cd->mda[i]->wd->m; - n_vals[i] = cd->mda[i]->wd->n; -} -} - -/*******************************************************************/ - -void get_current_densities_from_wave_code_ (core_data ** cdptr, int * dim_r, double * r, - int * m, int * n, - double * Jri, double * Jsi, double * Jpi, - double * Jre, double * Jse, double * Jpe) -{ -core_data *cd = *cdptr; - -//search for mode index -int num = -1; - -for (int i=0; idim; i++) -{ - if (cd->mda[i]->wd->m == *m && cd->mda[i]->wd->n == *n) - { - num = i; - break; - } -} - -if (num == -1) -{ - fprintf (stdout, "\nwarning: get_current_densities_from_wave_code: (%d, %d) mode is not in the spectrum.", *m, *n); - return; -} - -for (int i=0; i<*dim_r; i++) -{ - int ind = 2*i; - cd->mda[num]->eval_current_density (r[i], 0, 0, 0, Jri+ind); - cd->mda[num]->eval_current_density (r[i], 0, 0, 1, Jsi+ind); - cd->mda[num]->eval_current_density (r[i], 0, 0, 2, Jpi+ind); - cd->mda[num]->eval_current_density (r[i], 0, 1, 0, Jre+ind); - cd->mda[num]->eval_current_density (r[i], 0, 1, 1, Jse+ind); - cd->mda[num]->eval_current_density (r[i], 0, 1, 2, Jpe+ind); -} -} - -/*******************************************************************/ - -void activate_kilca_modules_for_flre_zone_ (core_data ** cdptr) -{ -//!The function activates the fortran modules for flre zone - -flre_zone * fz = static_cast((*cdptr)->mda[0]->zones[0]); - -activate_fortran_modules_for_zone_ (&fz); -} - -/*******************************************************************/ - -void deactivate_kilca_modules_for_flre_zone_ (core_data ** cdptr) -{ -//!The function activates the fortran modules for flre zone - -flre_zone * fz = static_cast((*cdptr)->mda[0]->zones[0]); - -deactivate_fortran_modules_for_zone_ (&fz); -} - -/*******************************************************************/ - -void -get_kilca_conductivity_array_ -( -core_data ** cdptr, -int * m, -int * n, -int * zone_ind, -int * spec, -int * flreo, -int * dim, -double ** r, -double ** cptr -) -{ -core_data *cd = *cdptr; - -//search for mode index -int num = -1; - -for (int i=0; idim; i++) -{ - if (cd->mda[i]->wd->m == *m && cd->mda[i]->wd->n == *n) - { - num = i; - break; - } -} - -if (num == -1) -{ - fprintf (stdout, "\nwarning: get_kilca_conductivity_array: (%d, %d) mode is not in the spectrum.", *m, *n); - return; -} - -flre_zone * zone = static_cast(cd->mda[num]->zones[*zone_ind]); - -*flreo = zone->flre_order; -*dim = zone->cp->dimx; -*r = zone->cp->x; -*cptr = &(zone->cp->K[zone->cp->iKs(*spec, 0, 0, 0, 0, 0, 0, 0)]); -} - -/*******************************************************************/ - -void -calc_conductivity_matrices_for_mode_ -(core_data ** cdptr, char const * run_path, int * pathlength, int * m, int * n) -{ -//!The function computes wave fields and other quantities which migth be obtained by subsequent calls of other get_* () interface functions - -//gets path to the project -char * path = new char[1024]; - -memcpy (path, run_path, *pathlength); - -path[*pathlength] = '\0'; //end of string symbol - -if (path[strlen(path)-1] != '/') strcat(path, "/"); - -//!Allocates core data structure containing pointers to all important code data -core_data * cd = new core_data (path); -set_core_data_in_core_module_ (&cd); -*cdptr = cd; - -cd->calc_and_set_mode_independent_core_data (); - -cd->calc_and_set_mode_dependent_core_data_antenna_interface (*m, *n, 1); - -delete [] path; -} - -/*******************************************************************/ - -void get_mode_parameters_ (core_data ** cdptr, int * m, int * n, double * kz, double * omega_mov_re, double * omega_mov_im) -{ -core_data *cd = *cdptr; - -//search for mode index -int num = -1; - -for (int i=0; idim; i++) -{ - if (cd->mda[i]->wd->m == *m && cd->mda[i]->wd->n == *n) - { - num = i; - break; - } -} - -if (num == -1) -{ - fprintf (stdout, "\nwarning: get_kilca_conductivity_array: (%d, %d) mode is not in the spectrum.", *m, *n); - return; -} - -*kz = cd->mda[num]->wd->n / cd->bp->sd->bs->rtor; - -*omega_mov_re = real(cd->mda[num]->wd->omov); -*omega_mov_im = imag(cd->mda[num]->wd->omov); -} - -/*******************************************************************/ - -void set_wave_parameters_ (core_data ** cdptr, int * m, int * n) -{ -core_data *cd = *cdptr; - -//search for mode index -int num = -1; - -for (int i=0; idim; i++) -{ - if (cd->mda[i]->wd->m == *m && cd->mda[i]->wd->n == *n) - { - num = i; - break; - } -} - -if (num == -1) -{ - fprintf (stdout, "\nwarning: set_wave_parameters: (%d, %d) mode is not in the spectrum.", *m, *n); - return; -} - -//set_wave_parameters_in_mode_data_module_(&(cd->mda[num]->wd->m), &(cd->mda[num]->wd->n), -// &(real(cd->mda[num]->wd->olab)), &(imag(cd->mda[num]->wd->olab)), -// &(real(cd->mda[num]->wd->omov)), &(imag(cd->mda[num]->wd->omov))); - -int mm = cd->mda[num]->wd->m, nn = cd->mda[num]->wd->n; - -double olab_re = real(cd->mda[num]->wd->olab), olab_im = imag(cd->mda[num]->wd->olab); -double omov_re = real(cd->mda[num]->wd->omov), omov_im = imag(cd->mda[num]->wd->omov); - -set_wave_parameters_in_mode_data_module_(&mm, &nn, &olab_re, &olab_im, &omov_re, &omov_im); -} - -/*******************************************************************/ - -void unset_wave_parameters_ (void) -{ -clear_all_data_in_mode_data_module_(); -} - -/*******************************************************************/ diff --git a/KiLCA/interface/wave_code_interface.h b/KiLCA/interface/wave_code_interface.h deleted file mode 100644 index fc86fba9..00000000 --- a/KiLCA/interface/wave_code_interface.h +++ /dev/null @@ -1,95 +0,0 @@ -/*! \file wave_code_interface.h - \brief The declarations of functions implementing Fortran interface to KiLCA library functions (for balance code). -*/ - -#include -#include -#include -#include -#include -#include - -#include "core.h" - -/*******************************************************************/ - -extern "C" -{ -void calc_wave_code_data_ (core_data ** cdptr, char const * run_path, int * pathlength); - -void calc_wave_code_data_for_mode_ (core_data ** cdptr, char const * run_path, int * pathlength, int * m, int * n); - -void clear_wave_code_data_ (core_data ** cdptr); - -void get_basic_background_profiles_from_wave_code_ (core_data ** cdptr, int * dim_r, - double * r, double * q, double * n, - double * Ti, double * Te, double * Vth, - double * Vz, double * dPhi0); - -void get_wave_vectors_from_wave_code_ (core_data ** cdptr, int * dim_r, double * r, - int * m, int * n, double * ks, double * kp); - -void get_background_magnetic_fields_from_wave_code_ (core_data ** cdptr, int * dim_r, - double * r, double *Bt, double *Bz, - double *B0); - -void get_wave_fields_from_wave_code_ (core_data ** cdptr, int * dim_r, double * r, - int * m, int * n, - double * Er, double * Es, double * Ep, - double * Et, double * Ez, - double * Br, double * Bs, double * Bp, - double * Bt, double * Bz); - -void get_diss_power_density_from_wave_code_ (core_data ** cdptr, int * dim_r, double * r, - int * m, int * n, - int * type, int * spec, double * pdis); - -void get_antenna_spectrum_dim_ (core_data ** cdptr, int * dim_mn); - -void get_antenna_spectrum_numbers_ (core_data ** cdptr, int * dim_mn, int * m_vals, int * nvals); - -void get_collision_frequences_from_wave_code_ (core_data ** cdptr, int * dim_r, double * r, - double * nui, double * nue); - -void get_current_densities_from_wave_code_ (core_data ** cdptr, int * dim_r, double * r, - int * m, int * n, - double * Jri, double * Jsi, double * Jpi, - double * Jre, double * Jse, double * Jpe); - -//get profiles from balance code: -void get_background_dimension_from_balance_ (int *dimx); - -void get_background_profiles_from_balance_ (int *dimx, double *x, double *q, double *n, - double *Ti, double *Te, - double *Vth, double *Vz, double *Er); - -void activate_kilca_modules_for_flre_zone_ (core_data ** cdptr); - -void deactivate_kilca_modules_for_flre_zone_ (core_data ** cdptr); - -void -get_kilca_conductivity_array_ -( -core_data ** cdptr, -int * m, -int * n, -int * zone_ind, -int * spec, -int * flreo, -int * dim, -double ** r, -double ** cptr -); - -void -calc_conductivity_matrices_for_mode_ -(core_data ** cdptr, char const * run_path, int * pathlength, int * m, int * n); - -void get_mode_parameters_ (core_data ** cdptr, int * m, int * n, double * kz, double * omega_mov_re, double * omega_mov_im); - -void set_wave_parameters_ (core_data ** cdptr, int * m, int * n); - -void unset_wave_parameters_ (void); -} - -/*******************************************************************/ diff --git a/KiLCA/interface/wave_code_interface_m.f90 b/KiLCA/interface/wave_code_interface_m.f90 new file mode 100644 index 00000000..f57a0fb8 --- /dev/null +++ b/KiLCA/interface/wave_code_interface_m.f90 @@ -0,0 +1,486 @@ +!> Fortran interface to KiLCA library functions for the balance code +!> (QL-Balance/KIM), formerly interface/wave_code_interface.{h,cpp}. All +!> entry points keep their original bind(C) names (called by the +!> pre-existing legacy Fortran KiLCA/interface/wave_code_data_64bit.f90 and +!> QL-Balance/src/base/wave_code_data_64bit.f90, both by-reference F77-style +!> callers, so every dummy below is by-reference, matching the oracle's +!> pointer-typed C parameters, never VALUE unless the oracle itself took a +!> plain (non-pointer) scalar). +module kilca_wave_code_interface_m + use, intrinsic :: iso_c_binding, only: c_int, c_intptr_t, c_double, c_double_complex, & + c_char, c_ptr, c_loc, c_f_pointer, c_null_ptr, c_null_char + use constants, only: dp + use kilca_core_data_m, only: core_data_create_, core_data_destroy_, & + core_data_calc_and_set_mode_independent_, & + core_data_calc_and_set_mode_dependent_antenna_interface_, & + core_data_calc_and_set_mode_dependent_antenna_interface_mn_, & + core_data_get_dim_, core_data_get_mda_element_, core_data_get_bp_ + use kilca_mode_data_m, only: mode_data_get_wd_, mode_data_get_zone_handle_, & + mode_data_eval_EB_fields_, mode_data_eval_diss_power_density_, & + mode_data_eval_current_density_ + use kilca_wave_data_m, only: wave_data_get_m, wave_data_get_n, & + wave_data_get_olab_re, wave_data_get_olab_im, & + get_wave_data_obj_omov_re, get_wave_data_obj_omov_im + use kilca_flre_zone_m, only: activate_fortran_modules_for_zone_, & + deactivate_fortran_modules_for_zone_, flre_zone_get_flre_order_, flre_zone_get_cp_ + use kilca_cond_profiles_m, only: get_cond_dimx, get_cond_x_ptr, get_cond_k_ptr, get_cond_iks + use kilca_transforms_m, only: transform_EB_from_cyl_to_rsp + use kilca_background_data_m, only: background_interp_in_lab_frame, & + eval_hthz_native => eval_hthz + implicit none + private + + public :: calc_wave_code_data_, calc_wave_code_data_for_mode_, clear_wave_code_data_ + public :: get_basic_background_profiles_from_wave_code_ + public :: get_wave_vectors_from_wave_code_ + public :: get_background_magnetic_fields_from_wave_code_ + public :: get_wave_fields_from_wave_code_ + public :: get_diss_power_density_from_wave_code_ + public :: get_antenna_spectrum_dim_, get_antenna_spectrum_numbers_ + public :: get_collision_frequences_from_wave_code_ + public :: get_current_densities_from_wave_code_ + public :: activate_kilca_modules_for_flre_zone_, deactivate_kilca_modules_for_flre_zone_ + public :: get_kilca_conductivity_array_, calc_conductivity_matrices_for_mode_ + public :: get_mode_parameters_, set_wave_parameters_, unset_wave_parameters_ + + interface + real(c_double) function get_background_rtor() bind(C, name="get_background_rtor_") + import :: c_double + end function get_background_rtor + + !> Matches background_data_m's own (not exported) definitions - + !> single-radius evaluators, each writing one element per call. + subroutine get_background_magnetic_fields(rval, Bt, Bz, B0) & + bind(C, name="get_background_magnetic_fields_") + import :: c_double + real(c_double), value :: rval + real(c_double), intent(out) :: Bt(1), Bz(1), B0(1) + end subroutine get_background_magnetic_fields + + subroutine get_background_collision_freqs(rval, nui, nue) & + bind(C, name="get_background_collision_freqs_") + import :: c_double + real(c_double), value :: rval + real(c_double), intent(out) :: nui(1), nue(1) + end subroutine get_background_collision_freqs + + !> Pre-existing legacy Fortran (core_m.f90), stores the core_data + !> handle for later opaque-handle callback use. + subroutine set_core_data_in_core_module(cd) bind(C, name="set_core_data_in_core_module_") + import :: c_intptr_t + integer(c_intptr_t), intent(in) :: cd + end subroutine set_core_data_in_core_module + + subroutine set_wave_parameters_in_mode_data_module(m, n, olab_re, olab_im, & + omov_re, omov_im) bind(C, name="set_wave_parameters_in_mode_data_module_") + import :: c_int, c_double + integer(c_int), intent(in) :: m, n + real(c_double), intent(in) :: olab_re, olab_im, omov_re, omov_im + end subroutine set_wave_parameters_in_mode_data_module + + subroutine clear_all_data_in_mode_data_module() & + bind(C, name="clear_all_data_in_mode_data_module_") + end subroutine clear_all_data_in_mode_data_module + end interface + +contains + + !> --- entry points used by the antenna-driven (run-the-whole-code) path --- + + subroutine calc_wave_code_data_(cdptr, run_path, pathlength) & + bind(C, name="calc_wave_code_data_") + integer(c_intptr_t), intent(out) :: cdptr + character(kind=c_char), intent(in) :: run_path(*) + integer(c_int), intent(in) :: pathlength + character(kind=c_char), allocatable :: cpath(:) + + cpath = to_cstr(build_path(run_path, pathlength)) + cdptr = core_data_create_(cpath) + call set_core_data_in_core_module(cdptr) + + call core_data_calc_and_set_mode_independent_(cdptr) + call core_data_calc_and_set_mode_dependent_antenna_interface_(cdptr) + end subroutine calc_wave_code_data_ + + subroutine calc_wave_code_data_for_mode_(cdptr, run_path, pathlength, m, n) & + bind(C, name="calc_wave_code_data_for_mode_") + integer(c_intptr_t), intent(out) :: cdptr + character(kind=c_char), intent(in) :: run_path(*) + integer(c_int), intent(in) :: pathlength, m, n + character(kind=c_char), allocatable :: cpath(:) + + cpath = to_cstr(build_path(run_path, pathlength)) + cdptr = core_data_create_(cpath) + call set_core_data_in_core_module(cdptr) + + call core_data_calc_and_set_mode_independent_(cdptr) + call core_data_calc_and_set_mode_dependent_antenna_interface_mn_(cdptr, m, n, 0_c_int) + end subroutine calc_wave_code_data_for_mode_ + + subroutine clear_wave_code_data_(cdptr) bind(C, name="clear_wave_code_data_") + integer(c_intptr_t), intent(in) :: cdptr + call core_data_destroy_(cdptr) + end subroutine clear_wave_code_data_ + + subroutine get_basic_background_profiles_from_wave_code_(cdptr, dim_r, r, q, n, & + Ti, Te, Vth, Vz, dPhi0) bind(C, name="get_basic_background_profiles_from_wave_code_") + integer(c_intptr_t), intent(in) :: cdptr + integer(c_int), intent(in) :: dim_r + real(c_double), intent(in) :: r(0:dim_r - 1) + real(c_double), intent(out) :: q(0:dim_r - 1), n(0:dim_r - 1) + real(c_double), intent(out) :: Ti(0:dim_r - 1), Te(0:dim_r - 1) + real(c_double), intent(inout) :: Vth(0:dim_r - 1), Vz(0:dim_r - 1), dPhi0(0:dim_r - 1) + + call background_interp_in_lab_frame(dim_r, r, q, n, Ti, Te, Vth, Vz, dPhi0) + end subroutine get_basic_background_profiles_from_wave_code_ + + subroutine get_wave_vectors_from_wave_code_(cdptr, dim_r, r, m, n, ks, kp) & + bind(C, name="get_wave_vectors_from_wave_code_") + integer(c_intptr_t), intent(in) :: cdptr + integer(c_int), intent(in) :: dim_r, m, n + real(c_double), intent(in) :: r(0:dim_r - 1) + real(c_double), intent(out) :: ks(0:dim_r - 1), kp(0:dim_r - 1) + integer :: i + real(dp) :: kth, kz, htz(0:1) + + do i = 0, dim_r - 1 + kth = real(m, dp)/r(i) + kz = real(n, dp)/get_background_rtor() + call eval_hthz_native(r(i), 0, 0, c_null_ptr, htz) + kp(i) = htz(0)*kth + htz(1)*kz + ks(i) = htz(1)*kth - htz(0)*kz + end do + end subroutine get_wave_vectors_from_wave_code_ + + subroutine get_background_magnetic_fields_from_wave_code_(cdptr, dim_r, r, Bt, Bz, B0) & + bind(C, name="get_background_magnetic_fields_from_wave_code_") + integer(c_intptr_t), intent(in) :: cdptr + integer(c_int), intent(in) :: dim_r + real(c_double), intent(in) :: r(0:dim_r - 1) + real(c_double), intent(out) :: Bt(0:dim_r - 1), Bz(0:dim_r - 1), B0(0:dim_r - 1) + integer :: i + + do i = 0, dim_r - 1 + call get_background_magnetic_fields(r(i), Bt(i), Bz(i), B0(i)) + end do + end subroutine get_background_magnetic_fields_from_wave_code_ + + subroutine get_collision_frequences_from_wave_code_(cdptr, dim_r, r, nui, nue) & + bind(C, name="get_collision_frequences_from_wave_code_") + integer(c_intptr_t), intent(in) :: cdptr + integer(c_int), intent(in) :: dim_r + real(c_double), intent(in) :: r(0:dim_r - 1) + real(c_double), intent(out) :: nui(0:dim_r - 1), nue(0:dim_r - 1) + integer :: i + + do i = 0, dim_r - 1 + call get_background_collision_freqs(r(i), nui(i), nue(i)) + end do + end subroutine get_collision_frequences_from_wave_code_ + + subroutine get_wave_fields_from_wave_code_(cdptr, dim_r, r, m, n, & + Er, Es, Ep, Et, Ez, Br, Bs, Bp, Bt, Bz) & + bind(C, name="get_wave_fields_from_wave_code_") + integer(c_intptr_t), intent(in) :: cdptr + integer(c_int), intent(in) :: dim_r, m, n + real(c_double), intent(in) :: r(0:dim_r - 1) + real(c_double), intent(out) :: Er(0:2*dim_r - 1), Es(0:2*dim_r - 1), Ep(0:2*dim_r - 1) + real(c_double), intent(out) :: Et(0:2*dim_r - 1), Ez(0:2*dim_r - 1) + real(c_double), intent(out) :: Br(0:2*dim_r - 1), Bs(0:2*dim_r - 1), Bp(0:2*dim_r - 1) + real(c_double), intent(out) :: Bt(0:2*dim_r - 1), Bz(0:2*dim_r - 1) + integer :: i, num, ind, comp + real(c_double) :: EBflat(12) + complex(c_double_complex) :: EBcyl(6), EBrsp(6) + + num = find_mode_index(cdptr, m, n) + if (num == -1) then + write (*, '(/,a,i0,a,i0,a)') & + 'warning: get_wave_fields_from_wave_code: (', m, ', ', n, & + ') mode is not in the spectrum.' + return + end if + + do i = 0, dim_r - 1 + call mode_data_eval_EB_fields_(core_data_get_mda_element_(cdptr, num), r(i), EBflat) + do comp = 1, 6 + EBcyl(comp) = cmplx(EBflat(2*comp - 1), EBflat(2*comp), c_double_complex) + end do + call transform_EB_from_cyl_to_rsp(core_data_get_bp_(cdptr), r(i), EBcyl, EBrsp) + + ind = 2*i + Er(ind) = real(EBcyl(1), dp); Er(ind + 1) = aimag(EBcyl(1)) + Es(ind) = real(EBrsp(2), dp); Es(ind + 1) = aimag(EBrsp(2)) + Ep(ind) = real(EBrsp(3), dp); Ep(ind + 1) = aimag(EBrsp(3)) + Et(ind) = real(EBcyl(2), dp); Et(ind + 1) = aimag(EBcyl(2)) + Ez(ind) = real(EBcyl(3), dp); Ez(ind + 1) = aimag(EBcyl(3)) + Br(ind) = real(EBcyl(4), dp); Br(ind + 1) = aimag(EBcyl(4)) + Bs(ind) = real(EBrsp(5), dp); Bs(ind + 1) = aimag(EBrsp(5)) + Bp(ind) = real(EBrsp(6), dp); Bp(ind + 1) = aimag(EBrsp(6)) + Bt(ind) = real(EBcyl(5), dp); Bt(ind + 1) = aimag(EBcyl(5)) + Bz(ind) = real(EBcyl(6), dp); Bz(ind + 1) = aimag(EBcyl(6)) + end do + end subroutine get_wave_fields_from_wave_code_ + + subroutine get_diss_power_density_from_wave_code_(cdptr, dim_r, r, m, n, & + ttype, spec, pdis) bind(C, name="get_diss_power_density_from_wave_code_") + integer(c_intptr_t), intent(in) :: cdptr + integer(c_int), intent(in) :: dim_r, m, n, ttype, spec + real(c_double), intent(in) :: r(0:dim_r - 1) + real(c_double), intent(out) :: pdis(0:dim_r - 1) + integer :: i, num + integer(c_intptr_t) :: mdh + + num = find_mode_index(cdptr, m, n) + if (num == -1) then + !> Oracle copy-paste quirk preserved: this warning literally + !> says "get_wave_fields_from_wave_code" in the C++ source too. + write (*, '(/,a,i0,a,i0,a)') & + 'warning: get_wave_fields_from_wave_code: (', m, ', ', n, & + ') mode is not in the spectrum.' + return + end if + + mdh = core_data_get_mda_element_(cdptr, num) + do i = 0, dim_r - 1 + call mode_data_eval_diss_power_density_(mdh, r(i), ttype, spec, pdis(i)) + end do + end subroutine get_diss_power_density_from_wave_code_ + + subroutine get_antenna_spectrum_dim_(cdptr, dim_mn) bind(C, name="get_antenna_spectrum_dim_") + integer(c_intptr_t), intent(in) :: cdptr + integer(c_int), intent(out) :: dim_mn + dim_mn = core_data_get_dim_(cdptr) + end subroutine get_antenna_spectrum_dim_ + + subroutine get_antenna_spectrum_numbers_(cdptr, dim_mn, m_vals, n_vals) & + bind(C, name="get_antenna_spectrum_numbers_") + integer(c_intptr_t), intent(in) :: cdptr + integer(c_int), intent(in) :: dim_mn + integer(c_int), intent(out) :: m_vals(0:dim_mn - 1), n_vals(0:dim_mn - 1) + integer :: i + integer(c_intptr_t) :: wd + + if (dim_mn /= core_data_get_dim_(cdptr)) then + write (*, '(a)') 'warning: get_antenna_spectrum_numbers: spectrum dimensions must match' + return + end if + + do i = 0, dim_mn - 1 + wd = mode_data_get_wd_(core_data_get_mda_element_(cdptr, i)) + m_vals(i) = wave_data_get_m(intptr_to_cptr(wd)) + n_vals(i) = wave_data_get_n(intptr_to_cptr(wd)) + end do + end subroutine get_antenna_spectrum_numbers_ + + subroutine get_current_densities_from_wave_code_(cdptr, dim_r, r, m, n, & + Jri, Jsi, Jpi, Jre, Jse, Jpe) bind(C, name="get_current_densities_from_wave_code_") + integer(c_intptr_t), intent(in) :: cdptr + integer(c_int), intent(in) :: dim_r, m, n + real(c_double), intent(in) :: r(0:dim_r - 1) + real(c_double), intent(out) :: Jri(0:2*dim_r - 1), Jsi(0:2*dim_r - 1), Jpi(0:2*dim_r - 1) + real(c_double), intent(out) :: Jre(0:2*dim_r - 1), Jse(0:2*dim_r - 1), Jpe(0:2*dim_r - 1) + integer :: i, num, ind + integer(c_intptr_t) :: mdh + + num = find_mode_index(cdptr, m, n) + if (num == -1) then + write (*, '(/,a,i0,a,i0,a)') & + 'warning: get_current_densities_from_wave_code: (', m, ', ', n, & + ') mode is not in the spectrum.' + return + end if + + mdh = core_data_get_mda_element_(cdptr, num) + do i = 0, dim_r - 1 + ind = 2*i + call mode_data_eval_current_density_(mdh, r(i), 0, 0, 0, Jri(ind)) + call mode_data_eval_current_density_(mdh, r(i), 0, 0, 1, Jsi(ind)) + call mode_data_eval_current_density_(mdh, r(i), 0, 0, 2, Jpi(ind)) + call mode_data_eval_current_density_(mdh, r(i), 0, 1, 0, Jre(ind)) + call mode_data_eval_current_density_(mdh, r(i), 0, 1, 1, Jse(ind)) + call mode_data_eval_current_density_(mdh, r(i), 0, 1, 2, Jpe(ind)) + end do + end subroutine get_current_densities_from_wave_code_ + + !> --- FLRE conductivity / QL-Balance coupling --- + + subroutine activate_kilca_modules_for_flre_zone_(cdptr) & + bind(C, name="activate_kilca_modules_for_flre_zone_") + integer(c_intptr_t), intent(in) :: cdptr + call activate_fortran_modules_for_zone_(mode_data_get_zone_handle_( & + core_data_get_mda_element_(cdptr, 0), 0)) + end subroutine activate_kilca_modules_for_flre_zone_ + + subroutine deactivate_kilca_modules_for_flre_zone_(cdptr) & + bind(C, name="deactivate_kilca_modules_for_flre_zone_") + integer(c_intptr_t), intent(in) :: cdptr + call deactivate_fortran_modules_for_zone_(mode_data_get_zone_handle_( & + core_data_get_mda_element_(cdptr, 0), 0)) + end subroutine deactivate_kilca_modules_for_flre_zone_ + + subroutine get_kilca_conductivity_array_(cdptr, m, n, zone_ind, spec, flreo, dimv, & + rptr, cptr) bind(C, name="get_kilca_conductivity_array_") + integer(c_intptr_t), intent(in) :: cdptr + integer(c_int), intent(in) :: m, n, zone_ind, spec + integer(c_int), intent(out) :: flreo, dimv + type(c_ptr), intent(out) :: rptr, cptr + integer :: num + integer(c_intptr_t) :: zone, zone_cp + integer(c_int) :: iks_off + real(c_double), pointer :: kflat(:) + type(c_ptr) :: kbase + + num = find_mode_index(cdptr, m, n) + if (num == -1) then + write (*, '(/,a,i0,a,i0,a)') & + 'warning: get_kilca_conductivity_array: (', m, ', ', n, & + ') mode is not in the spectrum.' + return + end if + + zone = mode_data_get_zone_handle_(core_data_get_mda_element_(cdptr, num), zone_ind) + zone_cp = flre_zone_get_cp_(zone) + + flreo = flre_zone_get_flre_order_(zone) + dimv = get_cond_dimx(zone_cp) + rptr = get_cond_x_ptr(zone_cp) + iks_off = get_cond_iks(zone_cp, spec, 0, 0, 0, 0, 0, 0, 0) + + kbase = get_cond_k_ptr(zone_cp) + call c_f_pointer(kbase, kflat, [iks_off + 1]) + cptr = c_loc(kflat(iks_off + 1)) + end subroutine get_kilca_conductivity_array_ + + subroutine calc_conductivity_matrices_for_mode_(cdptr, run_path, pathlength, m, n) & + bind(C, name="calc_conductivity_matrices_for_mode_") + integer(c_intptr_t), intent(out) :: cdptr + character(kind=c_char), intent(in) :: run_path(*) + integer(c_int), intent(in) :: pathlength, m, n + character(kind=c_char), allocatable :: cpath(:) + + cpath = to_cstr(build_path(run_path, pathlength)) + cdptr = core_data_create_(cpath) + call set_core_data_in_core_module(cdptr) + + call core_data_calc_and_set_mode_independent_(cdptr) + call core_data_calc_and_set_mode_dependent_antenna_interface_mn_(cdptr, m, n, 1_c_int) + end subroutine calc_conductivity_matrices_for_mode_ + + subroutine get_mode_parameters_(cdptr, m, n, kz, omega_mov_re, omega_mov_im) & + bind(C, name="get_mode_parameters_") + integer(c_intptr_t), intent(in) :: cdptr + integer(c_int), intent(in) :: m, n + real(c_double), intent(out) :: kz, omega_mov_re, omega_mov_im + integer :: num + integer(c_intptr_t) :: wd + + num = find_mode_index(cdptr, m, n) + if (num == -1) then + !> Oracle copy-paste quirk preserved: this warning literally + !> says "get_kilca_conductivity_array" in the C++ source too. + write (*, '(/,a,i0,a,i0,a)') & + 'warning: get_kilca_conductivity_array: (', m, ', ', n, & + ') mode is not in the spectrum.' + return + end if + + wd = mode_data_get_wd_(core_data_get_mda_element_(cdptr, num)) + kz = real(wave_data_get_n(intptr_to_cptr(wd)), dp)/get_background_rtor() + omega_mov_re = get_wave_data_obj_omov_re(intptr_to_cptr(wd)) + omega_mov_im = get_wave_data_obj_omov_im(intptr_to_cptr(wd)) + end subroutine get_mode_parameters_ + + subroutine set_wave_parameters_(cdptr, m, n) bind(C, name="set_wave_parameters_") + integer(c_intptr_t), intent(in) :: cdptr + integer(c_int), intent(in) :: m, n + integer :: num + integer(c_intptr_t) :: wd + integer(c_int) :: mm, nn + real(c_double) :: olab_re, olab_im, omov_re, omov_im + + num = find_mode_index(cdptr, m, n) + if (num == -1) then + write (*, '(/,a,i0,a,i0,a)') & + 'warning: set_wave_parameters: (', m, ', ', n, & + ') mode is not in the spectrum.' + return + end if + + wd = mode_data_get_wd_(core_data_get_mda_element_(cdptr, num)) + mm = wave_data_get_m(intptr_to_cptr(wd)) + nn = wave_data_get_n(intptr_to_cptr(wd)) + olab_re = wave_data_get_olab_re(intptr_to_cptr(wd)) + olab_im = wave_data_get_olab_im(intptr_to_cptr(wd)) + omov_re = get_wave_data_obj_omov_re(intptr_to_cptr(wd)) + omov_im = get_wave_data_obj_omov_im(intptr_to_cptr(wd)) + + call set_wave_parameters_in_mode_data_module(mm, nn, olab_re, olab_im, omov_re, omov_im) + end subroutine set_wave_parameters_ + + subroutine unset_wave_parameters_() bind(C, name="unset_wave_parameters_") + call clear_all_data_in_mode_data_module() + end subroutine unset_wave_parameters_ + + !> --- internal helpers --- + + !> Linear scan for the antenna-spectrum index of mode (m, n), mirroring + !> the oracle's identical inline loop repeated in 6 of the entry points + !> above. Returns a 0-based index, or -1 if (m, n) is not in cd's + !> spectrum. + function find_mode_index(cdptr, mval, nval) result(num) + integer(c_intptr_t), intent(in) :: cdptr + integer(c_int), intent(in) :: mval, nval + integer :: num + integer :: i, dimv + integer(c_intptr_t) :: wd + + num = -1 + dimv = core_data_get_dim_(cdptr) + do i = 0, dimv - 1 + wd = mode_data_get_wd_(core_data_get_mda_element_(cdptr, i)) + if (wave_data_get_m(intptr_to_cptr(wd)) == mval .and. & + wave_data_get_n(intptr_to_cptr(wd)) == nval) then + num = i + return + end if + end do + end function find_mode_index + + function intptr_to_cptr(h) result(cp) + integer(c_intptr_t), intent(in) :: h + type(c_ptr) :: cp + cp = transfer(h, cp) + end function intptr_to_cptr + + !> Reproduces calc_wave_code_data_'s C string handling exactly: + !> `strcpy(path, run_path); path[*pathlength] = '\0'; + !> if (path[strlen(path)-1] != '/') strcat(path, "/");` - run_path is + !> NOT null-terminated by the caller, pathlength is its true length. + function build_path(run_path, pathlength) result(path) + character(kind=c_char), intent(in) :: run_path(*) + integer(c_int), intent(in) :: pathlength + character(len=1024) :: path + integer :: i + + path = '' + do i = 1, pathlength + path(i:i) = run_path(i) + end do + if (path(pathlength:pathlength) /= '/') then + path(pathlength + 1:pathlength + 1) = '/' + end if + end function build_path + + function to_cstr(s) result(c) + character(len=*), intent(in) :: s + character(kind=c_char), allocatable :: c(:) + integer :: i, n + n = len_trim(s) + allocate (c(n + 1)) + do i = 1, n + c(i) = s(i:i) + end do + c(n + 1) = c_null_char + end function to_cstr + +end module kilca_wave_code_interface_m diff --git a/KiLCA/interp/interp.cpp b/KiLCA/interp/interp.cpp deleted file mode 100644 index 70aac775..00000000 --- a/KiLCA/interp/interp.cpp +++ /dev/null @@ -1,380 +0,0 @@ -/*! \file - \brief The definitions of functions declared in interp.h. -*/ - -#include -#include -#include -#include -#include -#include - -#include "interp.h" - -/*****************************************************************************/ - -void eval_neville_polynom_ (int * dim, const double * xg, const double * yg, int * deg, - double * x, int * Dmin, int * Dmax, int * ind, double * R) -{ -eval_neville_polynom(*dim, xg, yg, *deg, *x, *Dmin, *Dmax, ind, R); -} - -/*****************************************************************************/ - -void eval_neville_polynom_ready_ (const double * xa, const double * ya, int * deg, - double * x, int * Dmin, int * Dmax, double * R) -{ -eval_neville_polynom(xa, ya, *deg, *x, *Dmin, *Dmax, R); -} - -/*****************************************************************************/ - -int make_adaptive_grid (void (*func)(double *, double *, void *p), void *p, double a, double b, int deg, int *dim, double *eps, int order, int debug, double *x1, double *y1) -{ -//makes an adaptive x grid for moving interpolating polynoma of degree deg -//better to use odd degrees - -//additional space: -double *x2 = new double[(*dim)]; -double *y2 = new double[(*dim)]; - -double *xold = x1, *yold = y1, *xnew = x2, *ynew = y2; - -//initial grid: for 3 "moving" polynoma -int dimx = deg + 3; - -xold[0] = a; -xold[dimx-1] = b; - -double pi = 3.141592653589793238; - -for (int k=1; k<=deg+1; k++) //Chebyshev nodes -{ - xold[k] = 0.5*(a+b) - 0.5*(b-a)*cos((2*k-1)*pi/(2*(deg+1))); -} - -//initial y grid: -for (int k=0; k 1.0) errt = errt/abs(ym); - - if (errt > merr) //maximum error and its location - { - merr = errt; - xmerr = xc; - ymerr = ym; - } - - if (errt > *eps) flag = 1; //add the point to the grid - - //check xnew for dimension: - if (node >= *dim-2) - { - fprintf (stdout, "\n\nadaptive_grid_polynom: warning: maximum dimension is reached: node=%d: exit with the previous grid.", node); - fflush (stdout); - - if (x1 != xold) - { - for (int m=0; m 1.0) errt = errt/abs(yc); - - if (errt > merr) //maximum error - { - merr = errt; - xmerr = xc; - ymerr = yc; - } - - //checks values of errors: - if (!(erra < (*eps_a) || erra < errr) || xc-xold[k] > step) - { - flag = 1; - } - - if (!flag) continue; //accuracy is good: go to the next point in the old grid - - //adds new xc point to the new grid - xnew[node] = xc; - inew[node] = ic; - func_interp (ic, y, &ynew[node]); - node++; - } - - //add last grid point (b): k = dimx-1 - xnew[node] = xold[dimx-1]; - inew[node] = iold[dimx-1]; - ynew[node] = yold[dimx-1]; - node++; - - //switch arrays: - void *tmp; - - tmp = (void *)xold; - xold = xnew; - xnew = (double *)tmp; - - tmp = (void *)iold; - iold = inew; - inew = (int *)tmp; - - tmp = (void *)yold; - yold = ynew; - ynew = (double *)tmp; - - if (debug) - { - fprintf (stdout, "\n\nsparse_grid_polynom:\nfor %d iteration grid dimension is %d points.", iter, dimx); - - fprintf (stdout, "\nmaximum error (%le) is found at (%le) for function value (%le).", merr, xmerr, ymerr); - - fflush (stdout); - } - - if (node == dimx) break; //no new points have been added during iteration - - dimx = node; //new dimension of the new "old" array -} - -if (x1 != xold) -{ - for (int m=0; m -#include -#include -#include - -using namespace std; - -/*****************************************************************************/ - -struct interpolant -{ - int N; //polynomial degree - - int type; //type of the interpolation - - int *ind; //last search index for faster spline evaluation - - int dimx; /*dimension of a profile x grid (all the same)*/ - const double *x; /*x grid for profiles*/ - - double *C; /*matrix of splines coefficients*/ - - double *BC; /*array of binomial coefficients*/ - - double *fac; /*factors used in the splines evaluation*/ - - int calc_spline_boundaries (int dimy, const double *y, double *W); - int calc_spline_coefficients (int Imin, int dimy, const double *y, double *W); -}; - -/*****************************************************************************/ - -int make_adaptive_grid (void (*func)(double *, double *, void *p), void *p, double a, double b, int deg, int *dim, double *eps, int order, int debug, double *x1, double *y1); - -int sparse_grid_polynom (int dimx, double *x, double *y, int deg, double *eps_a, double *eps_r, double step, int *dim, double *x1, double *y1, int *ind1); - -inline void eval_neville_polynom (const double *xa, const double *ya, int deg, double x, int Dmin, int Dmax, double *R); - -inline void eval_neville_polynom (int dim, const double *xg, const double *yg, int deg, double x, int Dmin, int Dmax, int *ind, double *R); - -inline void eval_lagrange_polynom (int dim, const double *xg, const double *yg, int deg, double x, int Dmin, int Dmax, int *ind, double *R); - -void inline func_interp (int ind, double *y, double *yout); - -inline void find_index_for_interp (int deg, double x, int dimx, const double *xa, int *ind); - -inline void search_array (double x, int dimx, const double *xa, int *ind); - -inline int binary_search (double x, const double *xa, int ilo, int ihi); - -inline int sign (double x); - -/*****************************************************************************/ - -extern "C" -{ -void eval_neville_polynom_ (int * dim, const double * xg, const double * yg, int * deg, - double * x, int * Dmin, int * Dmax, int * ind, double * R); - -void eval_neville_polynom_ready_ (const double * xa, const double * ya, int * deg, - double * x, int * Dmin, int * Dmax, double * R); -} - -/*****************************************************************************/ - -#endif - -/*****************************************************************************/ - -inline void eval_lagrange_polynom (int dim, const double *xg, const double *yg, int deg, double x, int Dmin, int Dmax, int *ind, double *R) -{ -if (Dmax > 0) -{ - fprintf (stdout, "\nwarning: derivatives are not implemented yet!"); fflush (stdout); -} - -if (*ind < 0 || *ind > dim-1) *ind = dim/2; - -find_index_for_interp (deg, x, dim, xg, ind); - -const double *xa = xg + *ind; -const double *ya = yg + *ind; - -//derivatives are not implemented!!! -R[0] = 0.0e0; - -for (int n=0; n<=deg; n++) -{ - double fac = 1.0e0; - for (int i=0; i<=deg; i++) - { - if (i != n) fac *= (x - xa[i])/(xa[n]-xa[i]); - } - R[0] += ya[n]*fac; -} -} - -/*****************************************************************************/ - -inline void eval_neville_polynom (int dim, const double *xg, const double *yg, int deg, double x, int Dmin, int Dmax, int *ind, double *R) -{ -constexpr double tol = 1e-9; -if (x < xg[0] - tol || x > xg[dim-1] + tol) -{ - fprintf (stdout, "\nwarning: eval_neville_polynom: x is outside the array: x=%le", x); -} - -if (*ind < 0 || *ind > dim-1) *ind = dim/2; - -find_index_for_interp (deg, x, dim, xg, ind); - -eval_neville_polynom (xg + *ind, yg + *ind, deg, x, Dmin, Dmax, R); -} - -/*****************************************************************************/ - -inline void eval_neville_polynom (const double *xa, const double *ya, int deg, double x, int Dmin, int Dmax, double *R) -{ -constexpr double tol = 1e-9; -if (x < xa[0] - tol || x > xa[deg] + tol) -{ - fprintf (stdout, "\nwarning: eval_neville_polynom: x is outside the array [%.20le, %.20le]: x=%.20le", xa[0], xa[deg], x); -} - -double p[Dmax+2][deg+1][deg+1]; //0th derivative corresponds to p[1][][] - -for (int d=0; d=xa[dim-1] - Ok for splines and interpolation -//be careful to change something here: -if (x < xa[*ind]) -{ - *ind = binary_search (x, xa, 0, *ind); -} -else if (x >= xa[*ind+1]) -{ - *ind = binary_search (x, xa, *ind, dimx-1); -} -else -{} -} - -/*****************************************************************************/ - -inline int binary_search (double x, const double *xa, int ilo, int ihi) -{ -//warning: returns dim-2 for x>=xa[dim-1] - Ok for splines! -while (ihi > ilo+1) -{ - int i = (ihi+ilo)/2; - if (xa[i] > x) ihi = i; - else ilo = i; -} -return ilo; -} - -/*****************************************************************************/ - -inline int sign (double x) -{ -return (x<0.0) ? (-1):((x==0) ? 0:1); -} - -/*****************************************************************************/ diff --git a/KiLCA/interp/interp_m.f90 b/KiLCA/interp/interp_m.f90 new file mode 100644 index 00000000..c1e2febb --- /dev/null +++ b/KiLCA/interp/interp_m.f90 @@ -0,0 +1,241 @@ +!> Adaptive grid thinning by polynomial-interpolation error, formerly +!> KiLCA/math/adapt_grid/adaptive_grid_pol.cpp's `sparse_grid_polynom` -- the +!> 12-argument, multi-component overload declared in adaptive_grid_pol.h and +!> actually reachable from flre_zone.cpp (which includes adaptive_grid_pol.h, +!> not interp.h). There is an unrelated, scalar 11-argument function with the +!> same name in KiLCA/interp/interp.cpp; flre_zone.cpp never includes +!> interp.h, so that one is not its caller's target and is left untranslated. +!> +!> find_index_for_interp/search_array/binary_search/eval_interp_polynom/ +!> func_interp below are private helpers ported from the same +!> adaptive_grid_pol.{h,cpp} file. They are intentionally NOT kilca_neville_m +!> (a different module, ported earlier for a different call site): this +!> algorithm evaluates a plain Lagrange interpolation value only (no +!> derivatives, no out-of-range tolerance warning), with an explicit `dimy` +!> stride for vector-valued y data. +!> +!> The C++ pointer-swapping between (xold,yold,iold) and (xnew,ynew,inew) +!> each iteration (and the `if (x1 != xold)` skip-copy optimization at the +!> end) is a memory-reuse detail with no numerical effect; here the swap is +!> done with `move_alloc` and the final result is always copied into the +!> caller's x1/y1/ind1, unconditionally. +module kilca_interp_m + use constants, only: dp + implicit none + private + + public :: sparse_grid_polynom + +contains + + !> x(0:dimx_in-1)/y(dimy,0:dimx_in-1): the fine input grid/data. + !> eps_a/eps_r: in/out -- read as the requested tolerances, overwritten + !> on return with the achieved maximum error (matching the oracle, which + !> stores merr into both regardless of their distinct input meanings). + !> x1/y1/ind1(0:dimx_in-1): caller-allocated output buffers (thinned + !> grid, thinned data, source-index map), valid for 0:dimout-1 on return. + subroutine sparse_grid_polynom(x, dimx_in, y, dimy, deg, eps_a, eps_r, step, & + dimout, x1, y1, ind1) + integer, intent(in) :: dimx_in + integer, intent(in) :: dimy + real(dp), intent(in) :: x(0:dimx_in - 1) + real(dp), intent(in) :: y(dimy, 0:dimx_in - 1) + integer, intent(in) :: deg + real(dp), intent(inout) :: eps_a, eps_r + real(dp), intent(in) :: step + integer, intent(out) :: dimout + real(dp), intent(out) :: x1(0:dimx_in - 1) + real(dp), intent(out) :: y1(dimy, 0:dimx_in - 1) + integer, intent(out) :: ind1(0:dimx_in - 1) + + real(dp), allocatable :: xold(:), xnew(:), xtmp(:) + real(dp), allocatable :: yold(:, :), ynew(:, :), ytmp(:, :) + integer, allocatable :: iold(:), inew(:), itmp(:) + real(dp), allocatable :: ym(:) + integer :: xdim, dimx, k, ind, ic, node, j + real(dp) :: xc, yc, errr, erra, errt, merr, xmerr, ymerr + real(dp), parameter :: pi_local = 3.141592653589793238_dp + logical :: flag + + xdim = dimx_in + dimx = deg + 1 + + allocate (xold(0:xdim - 1), yold(dimy, 0:xdim - 1), iold(0:xdim - 1)) + allocate (xnew(0:xdim - 1), ynew(dimy, 0:xdim - 1), inew(0:xdim - 1)) + allocate (ym(dimy)) + + iold(0) = 0 + xold(0) = x(iold(0)) + + iold(dimx - 1) = xdim - 1 + xold(dimx - 1) = x(iold(dimx - 1)) + + do k = 1, deg - 1 + iold(k) = int(0.5_dp*xdim* & + (1.0_dp - cos(real(2*k - 1, dp)*pi_local/real(2*(deg - 1), dp)))) + xold(k) = x(iold(k)) + end do + + do k = 0, dimx - 1 + call func_interp(iold(k), yold(:, k), y, dimy) + end do + + merr = 0.0_dp + + do + ind = 0 + node = 0 + merr = 0.0_dp + xmerr = 0.0_dp + ymerr = 0.0_dp + + do k = 0, dimx - 2 + xnew(node) = xold(k) + inew(node) = iold(k) + ynew(:, node) = yold(:, k) + node = node + 1 + + ic = iold(k) + (iold(k + 1) - iold(k))/2 + + if (ic == iold(k)) cycle + + xc = x(ic) + + call find_index_for_interp(deg, xc, dimx, xold, ind) + + call eval_interp_polynom(deg, xold(ind:), yold(:, ind:), dimy, xc, ym) + + flag = .false. + do j = 1, dimy + yc = y(j, ic) + + erra = abs(yc - ym(j)) + errr = eps_r*abs(yc) + + errt = erra + if (abs(yc) > 1.0e-16_dp) errt = min(errt, errt/abs(yc)) + + if (errt > merr) then + merr = errt + xmerr = xc + ymerr = yc + end if + + if (.not. (erra < eps_a .or. erra < errr) .or. xc - xold(k) > step) then + flag = .true. + end if + end do + + if (.not. flag) cycle + + xnew(node) = xc + inew(node) = ic + call func_interp(ic, ynew(:, node), y, dimy) + node = node + 1 + end do + + xnew(node) = xold(dimx - 1) + inew(node) = iold(dimx - 1) + ynew(:, node) = yold(:, dimx - 1) + node = node + 1 + + call move_alloc(xold, xtmp) + call move_alloc(xnew, xold) + call move_alloc(xtmp, xnew) + + call move_alloc(yold, ytmp) + call move_alloc(ynew, yold) + call move_alloc(ytmp, ynew) + + call move_alloc(iold, itmp) + call move_alloc(inew, iold) + call move_alloc(itmp, inew) + + if (node == dimx) exit + + dimx = node + end do + + x1(0:dimx - 1) = xold(0:dimx - 1) + ind1(0:dimx - 1) = iold(0:dimx - 1) + y1(:, 0:dimx - 1) = yold(:, 0:dimx - 1) + + dimout = dimx + eps_a = merr + eps_r = merr + + if (dimx == xdim) then + write (*, '(a,i0,a)') & + 'sparse_grid_polynom: warning: no points removed from grid: dim = ', dimx, '.' + end if + end subroutine sparse_grid_polynom + + subroutine find_index_for_interp(deg, xc, dimx, xa, ind) + integer, intent(in) :: deg, dimx + real(dp), intent(in) :: xc, xa(0:*) + integer, intent(inout) :: ind + ind = min(ind + (deg - 1)/2, dimx - 2) + call search_array(xc, dimx, xa, ind) + ind = min(max(0, ind - (deg - 1)/2), dimx - deg - 1) + end subroutine find_index_for_interp + + subroutine search_array(xc, dimx, xa, ind) + real(dp), intent(in) :: xc, xa(0:*) + integer, intent(in) :: dimx + integer, intent(inout) :: ind + if (xc < xa(ind)) then + ind = binary_search(xc, xa, 0, ind) + else if (xc >= xa(ind + 1)) then + ind = binary_search(xc, xa, ind, dimx - 1) + end if + end subroutine search_array + + integer function binary_search(xc, xa, ilo, ihi) result(res) + real(dp), intent(in) :: xc, xa(0:*) + integer, intent(in) :: ilo, ihi + integer :: lo, hi, i + lo = ilo + hi = ihi + do while (hi > lo + 1) + i = (hi + lo)/2 + if (xa(i) > xc) then + hi = i + else + lo = i + end if + end do + res = lo + end function binary_search + + !> Plain (non-Neville) Lagrange evaluation at xc of the degree-`deg` + !> polynomial through (xg(0:deg), yg(:,0:deg)), vectorized over dimy + !> independent components. + subroutine eval_interp_polynom(deg, xg, yg, dimy, xc, yout) + integer, intent(in) :: deg, dimy + real(dp), intent(in) :: xg(0:*), yg(dimy, 0:*), xc + real(dp), intent(out) :: yout(dimy) + integer :: j, n, i + real(dp) :: fac + do j = 1, dimy + yout(j) = 0.0_dp + do n = 0, deg + fac = 1.0_dp + do i = 0, deg + if (i /= n) fac = fac*(xc - xg(i))/(xg(n) - xg(i)) + end do + yout(j) = yout(j) + yg(j, n)*fac + end do + end do + end subroutine eval_interp_polynom + + !> Oracle signature also takes (x, dimx); dropped here since the body + !> only ever reads y(:,ind) (the x/dimx parameters are unused in the + !> oracle's own definition too). + subroutine func_interp(ind, yout, y, dimy) + integer, intent(in) :: ind, dimy + real(dp), intent(in) :: y(dimy, 0:*) + real(dp), intent(out) :: yout(dimy) + yout = y(:, ind) + end subroutine func_interp + +end module kilca_interp_m diff --git a/KiLCA/interp/neville_m.f90 b/KiLCA/interp/neville_m.f90 new file mode 100644 index 00000000..6aee0529 --- /dev/null +++ b/KiLCA/interp/neville_m.f90 @@ -0,0 +1,127 @@ +!> Neville polynomial interpolation with derivatives. +!> +!> Fortran port of the Fortran-facing wrappers eval_neville_polynom_ and +!> eval_neville_polynom_ready_ formerly defined in interp.cpp (the underlying +!> algorithm lived as inline functions in interp.h). The C symbols and their +!> by-reference int*/double* argument convention are preserved so the Fortran +!> callers (KiLCA/QL-Balance wave_code_data) link unchanged. The C++ inline +!> versions in interp.h are untouched and keep serving the C++ call sites. +module kilca_neville_m + use, intrinsic :: iso_c_binding, only: c_int, c_double + use, intrinsic :: iso_fortran_env, only: error_unit + implicit none + private + + public :: eval_neville_polynom, eval_neville_polynom_ready + +contains + + subroutine eval_neville_polynom(dim, xg, yg, deg, x, Dmin, Dmax, ind, R) & + bind(C, name="eval_neville_polynom_") + integer(c_int), intent(in) :: dim, deg, Dmin, Dmax + integer(c_int), intent(inout) :: ind + real(c_double), intent(in) :: xg(0:*), yg(0:*), x + real(c_double), intent(out) :: R(0:*) + real(c_double), parameter :: tol = 1.0d-9 + integer(c_int) :: edeg + + if (x < xg(0) - tol .or. x > xg(dim - 1) + tol) & + write (error_unit, '(a,es12.4)') & + "warning: eval_neville_polynom: x is outside the array: x=", x + + ! Cap the moving-window degree to the points actually available. With + ! enough points (dim > deg, the production case) edeg == deg, matching + ! the C++ exactly; for a short grid the C++ formula dimx-deg-1 went + ! negative and indexed out of bounds, so clamp to stay in range. + edeg = min(deg, dim - 1) + + if (ind < 0 .or. ind > dim - 1) ind = dim/2 + call find_index_for_interp(edeg, x, dim, xg, ind) + + call neville_ready(xg(ind:ind + edeg), yg(ind:ind + edeg), edeg, x, Dmin, Dmax, R) + end subroutine eval_neville_polynom + + subroutine eval_neville_polynom_ready(xa, ya, deg, x, Dmin, Dmax, R) & + bind(C, name="eval_neville_polynom_ready_") + integer(c_int), intent(in) :: deg, Dmin, Dmax + real(c_double), intent(in) :: xa(0:*), ya(0:*), x + real(c_double), intent(out) :: R(0:*) + + call neville_ready(xa(0:deg), ya(0:deg), deg, x, Dmin, Dmax, R) + end subroutine eval_neville_polynom_ready + + subroutine neville_ready(xa, ya, deg, x, Dmin, Dmax, R) + integer(c_int), intent(in) :: deg, Dmin, Dmax + real(c_double), intent(in) :: xa(0:deg), ya(0:deg), x + real(c_double), intent(out) :: R(0:*) + real(c_double), parameter :: tol = 1.0d-9 + real(c_double), allocatable :: p(:, :, :) + integer(c_int) :: d, i, j, n + + if (x < xa(0) - tol .or. x > xa(deg) + tol) & + write (error_unit, '(a,3es24.16)') & + "warning: eval_neville_polynom: x outside [a,b]: ", xa(0), xa(deg), x + + allocate (p(0:Dmax + 1, 0:deg, 0:deg)) + p = 0.0d0 + + do d = 0, deg + p(1, d, d) = ya(d) + end do + + do n = 0, Dmax + do d = 1, deg + do i = 0, deg - d + j = i + d + p(n + 1, i, j) = n*(p(n, i, j - 1) - p(n, i + 1, j))/(xa(i) - xa(j)) + & + ((x - xa(j))/(xa(i) - xa(j)))*p(n + 1, i, j - 1) - & + ((x - xa(i))/(xa(i) - xa(j)))*p(n + 1, i + 1, j) + end do + end do + end do + + do n = Dmin, Dmax + R(n - Dmin) = p(n + 1, 0, deg) + end do + end subroutine neville_ready + + subroutine find_index_for_interp(deg, x, dimx, xa, ind) + integer(c_int), intent(in) :: deg, dimx + real(c_double), intent(in) :: x, xa(0:*) + integer(c_int), intent(inout) :: ind + + ind = min(ind + (deg - 1)/2, dimx - 2) + call search_array(x, dimx, xa, ind) + ind = min(max(0, ind - (deg - 1)/2), dimx - deg - 1) + end subroutine find_index_for_interp + + subroutine search_array(x, dimx, xa, ind) + real(c_double), intent(in) :: x, xa(0:*) + integer(c_int), intent(in) :: dimx + integer(c_int), intent(inout) :: ind + + if (x < xa(ind)) then + ind = binary_search(x, xa, 0, ind) + else if (x >= xa(ind + 1)) then + ind = binary_search(x, xa, ind, dimx - 1) + end if + end subroutine search_array + + integer(c_int) function binary_search(x, xa, ilo, ihi) result(res) + real(c_double), intent(in) :: x, xa(0:*) + integer(c_int), intent(in) :: ilo, ihi + integer(c_int) :: lo, hi, i + + lo = ilo; hi = ihi + do while (hi > lo + 1) + i = (hi + lo)/2 + if (xa(i) > x) then + hi = i + else + lo = i + end if + end do + res = lo + end function binary_search + +end module kilca_neville_m diff --git a/KiLCA/io/inout.cpp b/KiLCA/io/inout.cpp deleted file mode 100644 index 6e2c169e..00000000 --- a/KiLCA/io/inout.cpp +++ /dev/null @@ -1,735 +0,0 @@ -/*! \file - \brief The definitions of functions declared in inout.h. -*/ - -#include -#include -#include -#include - -#include "inout.h" -#include "shared.h" -#include "constants.h" - -/*******************************************************************/ - -int save_cmplx_matrix (int Nrows, int Ncols, int Npoints, const double *xgrid, const double *arr, const char *path_name) -{ -FILE *outfile; - -size_t nchar = 1024; - -char *full_name = new char[nchar]; - -int i, j, k; - -for (i=0; i *value) -{ -/*reads current line and stores value before # as a complex value*/ -size_t nchar = 1024; -char *char_buf = new char[nchar]; -const char delimiters[4] = {'#','\n','\0'}; -const char del[3] = {'(',',',')'}; -char *info; -double re, im; - -if (getline (&char_buf, &nchar, in) < 2) /*reads line*/ -{ - fprintf (stderr, "\nread_line_2get_complex: file reading error!\a\n"); - fflush (stderr); -} - -info = (char *) strtok (char_buf, delimiters); /*takes what is before #*/ -re = strtod((char *) strtok (info, del), NULL);/*takes what is before ,*/ -im = strtod((char *) strtok (NULL, del), NULL);/*takes what is before )*/ - -*value = re + I*im; - -/*printf ("\nvalue = (%le, %le)\n", re, im);*/ - -delete [] char_buf; -} - -/*-----------------------------------------------------------------*/ - -void read_line_2get_int (FILE *in, int *value) -{ -/*reads current line and stores value before # as an integer value*/ -size_t nchar = 1024; -char *char_buf = new char[nchar]; -const char delimiters[4] = {'#','\n','\0'}; -char *info; - -if (getline (&char_buf, &nchar, in) < 2) /*reads line*/ -{ - fprintf (stderr, "\nread_line_2get_int: file reading error!\a\n"); - fflush (stderr); -} - -*value = (int) strtol ((char *) strtok (char_buf, delimiters), NULL, 10);/*takes what is before #*/ -info = (char *) strtok (NULL, delimiters);/*takes what is after #*/ - -//fprintf(stdout, "\n%s: %d", info, *value);/*prints for check*/ -//fflush (stdout); - -delete [] char_buf; -} - -/*-----------------------------------------------------------------*/ - -void read_line_2get_string (FILE *in, char **value) -{ -/*reads current line and stores value before # () as a string value*/ -size_t nchar = 1024; -char *char_buf = new char[nchar]; -const char delimiters[4] = {'#','\n','\0'}; -char *info; -char *tmp; - -if (getline (&char_buf, &nchar, in) < 2) /*reads line*/ -{ - fprintf (stderr, "\nread_line_2get_string: file reading error!\a\n"); - fflush (stderr); -} - -tmp = (char *) strtok (char_buf, delimiters);/*takes what is before #*/ -info = (char *) strtok (NULL, delimiters);/*takes what is after #*/ -strcpy (*value, trim(tmp)); - -//fprintf(stdout, "\n%s: %s", info, *value);/*prints for check*/ -//fflush (stdout); - -delete [] char_buf; -} - -/*-----------------------------------------------------------------*/ - -void read_line_2skip_it (FILE *in, char **value) -{ -/*reads current line*/ -size_t nchar = 1024; -char *char_buf = new char[nchar]; - -getline (&char_buf, &nchar, in); /*reads line*/ - -//fprintf(stdout, "\n%s", char_buf);/*prints for check*/ -//fflush (stdout); - -delete [] char_buf; -} - -/*-----------------------------------------------------------------*/ - -int load_and_alloc_profile (char *name, int *dim, double **rgrid, double **qgrid) -{ -FILE *in; - -size_t nchar = 1024; - -char *file_name = new char[nchar]; - -strcpy (file_name, name); -strcat (file_name, ".dim"); - -if ((in=fopen(file_name, "r")) == NULL) -{ - fprintf (stderr, "\nfailed to open file %s\a\a\a\n", file_name); - exit(0); -} - -char *char_buf = new char[nchar]; - -getline (&char_buf, &nchar, in); /*reads line*/ - -fclose(in); - -*dim = (int) strtol (char_buf, NULL, 0); /*converts to an integer*/ - -*rgrid = new double[*dim]; -*qgrid = new double[*dim]; - -strcpy (file_name, name); -strcat (file_name, ".dat"); - -/*fprintf(stdout, "\nProfile %s has %d points.", file_name, *dim);*/ - -if ((in=fopen(file_name, "r")) == NULL) -{ - fprintf (stderr, "\nfailed to open file %s\a\a\a\n", file_name); - exit(0); -} - -char *tail_ptr1, *tail_ptr2; - -int i; -for (i=0; i<*dim; i++) -{ - if (feof(in) || ferror(in)) break; - if (getline (&char_buf, &nchar, in) < 1) /*reads line*/ - { - fprintf (stderr, "\nload_and_alloc_profile: file reading error!\a\n"); - } - (*rgrid)[i] = strtod (char_buf, &tail_ptr1); - (*qgrid)[i] = strtod (tail_ptr1, &tail_ptr2); -} - -if(i != *dim) -{ - fprintf(stderr, "\nerror: load_and_alloc_profile: read error or false array dimension!\a\n"); - exit(0); -} - -fclose (in); - -delete [] char_buf; -delete [] file_name; - -return 0; -} - -/*-----------------------------------------------------------------*/ - -int load_profile (char *name, int dim, double *rgrid, double *qgrid) -{ -FILE *in; - -size_t nchar = 1024; - -char *file_name = new char[nchar]; - -strcpy (file_name, name); -strcat (file_name, ".dim"); - -if ((in=fopen(file_name, "r")) == NULL) -{ - fprintf (stderr, "\nfailed to open file %s\a\a\a\n", file_name); - exit (0); -} - -char *char_buf = new char[nchar]; - -getline (&char_buf, &nchar, in); /*reads line*/ - -fclose(in); - -int dimt = (int) strtol (char_buf, NULL, 0); /*converts to an integer*/ - -if (dim != dimt) -{ - fprintf (stderr, "\ndimension=%d of the profile %s is different from the value=%d in set.in!", dimt, file_name, dim); - exit (0); -} - -strcpy (file_name, name); -strcat (file_name, ".dat"); - -/*fprintf(stdout, "\nProfile %s has %d points.", file_name, *dim);*/ - -if ((in=fopen(file_name, "r")) == NULL) -{ - fprintf (stderr, "\nfailed to open file %s\a\a\a\n", file_name); - exit(0); -} - -char *tail_ptr1, *tail_ptr2; - -int err = 0; - -int i; -for (i=0; i 0) num_lines++; - -fclose (in); - -delete [] char_buf; - -if (flag_print) -{ - fprintf (stdout, "\nfile %s contains %d non-empty lines\n", filename, num_lines); - fflush (stdout); -} - -return num_lines; -} - -/*-----------------------------------------------------------------*/ - -int load_complex_profile (char *name, int dim, double *rgrid, double *qgrid) -{ -FILE *in; - -size_t nchar = 1024; - -char *file_name = new char[nchar]; -char *char_buf = new char[nchar]; - -strcpy (file_name, name); -//strcat (file_name, ".dat"); - -/*fprintf(stdout, "\nProfile %s has %d points.", file_name, *dim);*/ - -if ((in=fopen(file_name, "r")) == NULL) -{ - fprintf (stderr, "\nfailed to open file %s\a\a\a\n", file_name); - exit(0); -} - -char *tail_ptr1, *tail_ptr2, *tail_ptr3; - -int i; -int err = 0; - -for (i=0; i 0) -{ - if (!(strchr (char_buf, '%') || strchr (char_buf, '#') || strchr (char_buf, '!'))) - { - num_lines++; - } -} - -fclose (in); - -delete [] char_buf; - -if (flag_print) -{ - fprintf (stdout, "\nfile %s contains %d non-empty lines\n", filename, num_lines); - fflush (stdout); -} - -return num_lines; -} - -/*-----------------------------------------------------------------*/ - -int load_data_file_with_comments (char *file_name, int dim, int ncols, double *rgrid, double *qgrid) -{ -//dim and ncols to be checked inside; ncols means number of y data columns! -//(x, y1, y2,...,yncols) - -if (dim != count_lines_in_file_with_comments (file_name, 0)) -{ - fprintf(stderr, "\nerror: load_data_file: read error or false input data dimension: %s\n", file_name); - exit(1); -} - -FILE *in; - -size_t nchar = ncols*1024; - -char *char_buf = new char[nchar]; - -if ((in=fopen(file_name, "r")) == NULL) -{ - fprintf (stderr, "\nload_data_file: failed to open file %s\n", file_name); - exit(1); -} - -char *str1, *str2; - -int i, k; -int err = 0; - -int ind = 0; - -int dimf = count_lines_in_file (file_name, 0); - -for (i=0; i - -using namespace std; - -int save_cmplx_matrix (int Nrows, int Ncols, int Npoints, const double *xgrid, const double *arr, const char *path_name); - -int save_cmplx_matrix_to_one_file (int Nrows, int Ncols, int Npoints, const double *xgrid, const double *arr, const char *full_name); - -int save_real_matrix_to_one_file (int order, int Nrows, int Ncols, int Npoints, const double *xgrid, const double *arr, const char *full_name); - -int save_real_array (int dim, const double *xgrid, const double *arr, const char *full_name); - -int save_complex_array (int dim, const double *xgrid, const double *arr, const char *full_name); - -char * trim (char *str); - -void read_line_2get_double (FILE *in, double *value); - -void read_line_2get_complex (FILE *in, complex *value); - -void read_line_2get_int (FILE *in, int *value); - -void read_line_2get_string (FILE *in, char **value); - -void read_line_2skip_it (FILE *in, char **value); - -int load_profile (char *name, int dim, double *rgrid, double *qgrid); - -int load_and_alloc_profile (char *name, int *dim, double **rgrid, double **qgrid); - -int count_lines_in_file (char *filename, int flag_print); - -int load_complex_profile (char *name, int dim, double *rgrid, double *qgrid); - -int load_data_file (char *file_name, int dim, int ncols, double *rgrid, double *qgrid); - -int count_lines_in_file_with_comments (char *filename, int flag_print); - -int load_data_file_with_comments (char *file_name, int dim, int ncols, double *rgrid, double *qgrid); - -#if defined(__cplusplus) -extern "C" -{ -#endif - -#if defined(__cplusplus) -} -#endif - -extern "C" -{ -void count_lines_in_file_ (char *filename, int *flag_print, int *dim); -} - -#endif diff --git a/KiLCA/io/inout_m.f90 b/KiLCA/io/inout_m.f90 new file mode 100644 index 00000000..24ae2837 --- /dev/null +++ b/KiLCA/io/inout_m.f90 @@ -0,0 +1,499 @@ +!> The file-I/O utilities ported from io/inout.h and io/inout.cpp: filename-based +!> savers/loaders (save_cmplx_matrix*, save_real_array, load_data_file, +!> count_lines_in_file and their with-comments variants) plus the FILE*-based +!> line readers (read_line_2get_*/read_line_2skip_it) called by the still-C++ +!> post_processing and progs entry points. The line readers keep the C +!> "FILE *" handle opaque as type(c_ptr) and read through libc getline, so their +!> C++ callers pass the fopen'd handle through unchanged. The confirmed-dead +!> functions (save_real_matrix_to_one_file/save_complex_array/trim/load_profile/ +!> load_and_alloc_profile/load_complex_profile) had zero callers across the +!> built targets and were dropped, completing the translation of inout.cpp. +module kilca_inout_m + use, intrinsic :: iso_c_binding, only: c_int, c_double, c_char, c_null_char, & + c_ptr, c_size_t, c_long, c_loc, c_f_pointer + use constants, only: dp + implicit none + private + + public :: save_cmplx_matrix_, save_cmplx_matrix_to_one_file_ + public :: save_real_array_, load_data_file_, count_lines_in_file_ + public :: read_line_2get_double_, read_line_2get_complex_ + public :: read_line_2get_int_, read_line_2get_string_, read_line_2skip_it_ + public :: count_lines_in_file_with_comments_, load_data_file_with_comments_ + + interface + function c_getline(lineptr, n, stream) result(nread) & + bind(C, name="getline") + import :: c_ptr, c_long + type(c_ptr), value :: lineptr + type(c_ptr), value :: n + type(c_ptr), value :: stream + integer(c_long) :: nread + end function c_getline + + function c_malloc(sz) result(p) bind(C, name="malloc") + import :: c_ptr, c_size_t + integer(c_size_t), value :: sz + type(c_ptr) :: p + end function c_malloc + + subroutine c_free(p) bind(C, name="free") + import :: c_ptr + type(c_ptr), value :: p + end subroutine c_free + end interface + +contains + + !> Mirrors save_cmplx_matrix exactly: one file per column "i", + !> path_name_i.dat, each row "x(k) re im re im ...". + function save_cmplx_matrix_(Nrows, Ncols, Npoints, xgrid, arr, path_name) & + result(ierr) bind(C, name="save_cmplx_matrix") + integer(c_int), value :: Nrows, Ncols, Npoints + real(c_double), intent(in) :: xgrid(0:Npoints - 1) + real(c_double), intent(in) :: arr(0:2*Nrows*Ncols*Npoints - 1) + character(kind=c_char), intent(in) :: path_name(*) + integer(c_int) :: ierr + + character(len=1024) :: fname + integer :: i, j, k, unit, ios + + do i = 0, Ncols - 1 + write (fname, '(a,a,i0,a)') c_string_to_fortran(path_name), '_', i, '.dat' + open (newunit=unit, file=trim(fname), status='replace', action='write', iostat=ios) + if (ios /= 0) then + write (*, '(a,a)') 'Failed to open file ', trim(fname) + cycle + end if + + do k = 0, Npoints - 1 + write (unit, '(es24.16e3)', advance='no') xgrid(k) + do j = 0, Nrows - 1 + write (unit, '(a,es24.16e3,a,es24.16e3)', advance='no') char(9), & + arr(2*Nrows*Ncols*k + 2*Nrows*i + 2*j), char(9), & + arr(2*Nrows*Ncols*k + 2*Nrows*i + 2*j + 1) + end do + write (unit, *) + end do + close (unit) + end do + + ierr = 0 + end function save_cmplx_matrix_ + + !> Mirrors save_cmplx_matrix_to_one_file: a complex Nrows x Ncols matrix + !> per point, columns-first (i outer, j inner), to one file. + function save_cmplx_matrix_to_one_file_(Nrows, Ncols, Npoints, xgrid, arr, full_name) & + result(ierr) bind(C, name="save_cmplx_matrix_to_one_file") + integer(c_int), value :: Nrows, Ncols, Npoints + real(c_double), intent(in) :: xgrid(0:Npoints - 1) + real(c_double), intent(in) :: arr(0:2*Nrows*Ncols*Npoints - 1) + character(kind=c_char), intent(in) :: full_name(*) + integer(c_int) :: ierr + + integer :: i, j, k, unit, ios + + open (newunit=unit, file=trim(c_string_to_fortran(full_name)), status='replace', & + action='write', iostat=ios) + if (ios /= 0) then + write (*, '(a,a)') 'Failed to open file ', trim(c_string_to_fortran(full_name)) + ierr = 1 + return + end if + + do k = 0, Npoints - 1 + write (unit, '(es24.16e3)', advance='no') xgrid(k) + do i = 0, Nrows - 1 + do j = 0, Ncols - 1 + write (unit, '(a,es24.16e3,a,es24.16e3)', advance='no') char(9), & + arr(2*Nrows*Ncols*k + 2*Nrows*j + 2*i), char(9), & + arr(2*Nrows*Ncols*k + 2*Nrows*j + 2*i + 1) + end do + end do + write (unit, *) + end do + close (unit) + + ierr = 0 + end function save_cmplx_matrix_to_one_file_ + + !> Mirrors save_real_array: "x(k) arr(k)" per line. + function save_real_array_(dim_, xgrid, arr, full_name) result(ierr) & + bind(C, name="save_real_array") + integer(c_int), value :: dim_ + real(c_double), intent(in) :: xgrid(0:dim_ - 1), arr(0:dim_ - 1) + character(kind=c_char), intent(in) :: full_name(*) + integer(c_int) :: ierr + + integer :: k, unit, ios + + open (newunit=unit, file=trim(c_string_to_fortran(full_name)), status='replace', & + action='write', iostat=ios) + if (ios /= 0) then + write (*, '(a,a)') 'Failed to open file ', trim(c_string_to_fortran(full_name)) + ierr = 1 + return + end if + + do k = 0, dim_ - 1 + write (unit, '(es24.16e3,a,es24.16e3)') xgrid(k), char(9), arr(k) + end do + close (unit) + + ierr = 0 + end function save_real_array_ + + !> Mirrors count_lines_in_file: counts lines via a raw read loop + !> (matching the oracle's getline-until-EOF convention, not a + !> line-ending-aware text scan). + function count_lines_in_file_(filename, flag_print) result(num_lines) & + bind(C, name="count_lines_in_file") + character(kind=c_char), intent(in) :: filename(*) + integer(c_int), value :: flag_print + integer(c_int) :: num_lines + + character(len=1024) :: fname + integer :: unit, ios + character(len=65536) :: line + + fname = c_string_to_fortran(filename) + open (newunit=unit, file=trim(fname), status='old', action='read', iostat=ios) + if (ios /= 0) then + write (*, '(a,a)') 'count_lines_in_file: failed to open file ', trim(fname) + end if + + num_lines = 0 + do + read (unit, '(a)', iostat=ios) line + if (ios /= 0) exit + num_lines = num_lines + 1 + end do + + close (unit) + + if (flag_print /= 0) then + write (*, '(a,a,a,i0,a)') 'file ', trim(fname), ' contains ', num_lines, ' non-empty lines' + end if + end function count_lines_in_file_ + + !> Mirrors load_data_file exactly: dim must equal count_lines_in_file's + !> result; each line is (x, y_1, ..., y_ncols), columns stored + !> column-major in qgrid (qgrid(i + k*dim) for column k, row i). + function load_data_file_(file_name, dim_, ncols, rgrid, qgrid) result(ierr) & + bind(C, name="load_data_file") + character(kind=c_char), intent(in) :: file_name(*) + integer(c_int), value :: dim_, ncols + real(c_double), intent(out) :: rgrid(0:dim_ - 1) + real(c_double), intent(out) :: qgrid(0:dim_*ncols - 1) + integer(c_int) :: ierr + + character(len=1024) :: fname + integer :: unit, ios, i, k + real(dp) :: vals(0:ncols) + + fname = c_string_to_fortran(file_name) + + if (dim_ /= count_lines_in_file_(file_name, 0_c_int)) then + write (*, '(a,a)') & + 'error: load_data_file: read error or false input data dimension: ', trim(fname) + stop 1 + end if + + open (newunit=unit, file=trim(fname), status='old', action='read', iostat=ios) + if (ios /= 0) then + write (*, '(a,a)') 'load_data_file: failed to open file ', trim(fname) + stop 1 + end if + + ierr = 0 + do i = 0, dim_ - 1 + read (unit, *, iostat=ios) vals(0:ncols) + if (ios /= 0) then + write (*, '(a,a,a)') 'load_data_file: file ', trim(fname), ' reading error!' + stop 1 + end if + rgrid(i) = vals(0) + do k = 0, ncols - 1 + qgrid(i + k*dim_) = vals(k + 1) + end do + end do + + close (unit) + end function load_data_file_ + + !> Mirrors read_line_2get_double: reads one line from the C FILE* handle, + !> takes the text before '#' and parses it as a double (0 on no conversion, + !> matching strtod). + subroutine read_line_2get_double_(in, value) bind(C, name="read_line_2get_double") + type(c_ptr), value :: in + real(c_double), intent(out) :: value + + character(len=4096) :: sub + logical :: ok + integer :: ios + + call read_line_before_hash(in, sub, ok) + if (.not. ok) write (*, '(a)') 'read_line_2get_double: file reading error' + read (sub, *, iostat=ios) value + if (ios /= 0) value = 0.0_dp + end subroutine read_line_2get_double_ + + !> Mirrors read_line_2get_complex: the text before '#' is "(re,im)", which is + !> exactly Fortran list-directed complex input. + subroutine read_line_2get_complex_(in, value) bind(C, name="read_line_2get_complex") + type(c_ptr), value :: in + complex(c_double), intent(out) :: value + + character(len=4096) :: sub + logical :: ok + integer :: ios + + call read_line_before_hash(in, sub, ok) + if (.not. ok) write (*, '(a)') 'read_line_2get_complex: file reading error' + read (sub, *, iostat=ios) value + if (ios /= 0) value = (0.0_dp, 0.0_dp) + end subroutine read_line_2get_complex_ + + !> Mirrors read_line_2get_int: text before '#' parsed as an integer. + subroutine read_line_2get_int_(in, value) bind(C, name="read_line_2get_int") + type(c_ptr), value :: in + integer(c_int), intent(out) :: value + + character(len=4096) :: sub + logical :: ok + integer :: ios + + call read_line_before_hash(in, sub, ok) + if (.not. ok) write (*, '(a)') 'read_line_2get_int: file reading error' + read (sub, *, iostat=ios) value + if (ios /= 0) value = 0_c_int + end subroutine read_line_2get_int_ + + !> Mirrors read_line_2get_string: the first whitespace/tab-delimited token of + !> the text before '#' is copied (null-terminated) into the caller's buffer. + !> "value" is a C "char **"; *value is the destination char buffer. + subroutine read_line_2get_string_(in, value) bind(C, name="read_line_2get_string") + type(c_ptr), value :: in + type(c_ptr), value :: value + + character(len=4096) :: sub + logical :: ok + integer :: i, s, e, n + type(c_ptr), pointer :: destpp + character(kind=c_char), pointer :: dest(:) + + call read_line_before_hash(in, sub, ok) + if (.not. ok) write (*, '(a)') 'read_line_2get_string: file reading error' + + s = 0 + do i = 1, len(sub) + if (sub(i:i) /= ' ') then + if (sub(i:i) /= achar(9)) then + s = i + exit + end if + end if + end do + + n = 0 + if (s > 0) then + e = s + do i = s, len(sub) + if (sub(i:i) == ' ') exit + if (sub(i:i) == achar(9)) exit + e = i + end do + n = e - s + 1 + end if + + call c_f_pointer(value, destpp) + call c_f_pointer(destpp, dest, [n + 1]) + do i = 1, n + dest(i) = sub(s + i - 1:s + i - 1) + end do + dest(n + 1) = c_null_char + end subroutine read_line_2get_string_ + + !> Mirrors read_line_2skip_it: read and discard one line. "value" is unused, + !> matching the oracle. + subroutine read_line_2skip_it_(in, value) bind(C, name="read_line_2skip_it") + type(c_ptr), value :: in + type(c_ptr), value :: value + + character(len=4096) :: line + integer(c_long) :: nread + + call read_raw_line(in, line, nread) + end subroutine read_line_2skip_it_ + + !> Mirrors count_lines_in_file_with_comments: counts lines that contain none + !> of '%', '#', '!'. + function count_lines_in_file_with_comments_(filename, flag_print) & + result(num_lines) bind(C, name="count_lines_in_file_with_comments") + character(kind=c_char), intent(in) :: filename(*) + integer(c_int), value :: flag_print + integer(c_int) :: num_lines + + character(len=1024) :: fname + integer :: unit, ios + character(len=65536) :: line + + fname = c_string_to_fortran(filename) + open (newunit=unit, file=trim(fname), status='old', action='read', iostat=ios) + if (ios /= 0) then + write (*, '(a,a)') 'count_lines_in_file: failed to open file ', trim(fname) + end if + + num_lines = 0 + do + read (unit, '(a)', iostat=ios) line + if (ios /= 0) exit + if (index(line, '%') == 0 .and. index(line, '#') == 0 & + .and. index(line, '!') == 0) then + num_lines = num_lines + 1 + end if + end do + + close (unit) + + if (flag_print /= 0) then + write (*, '(a,a,a,i0,a)') 'file ', trim(fname), ' contains ', num_lines, & + ' non-empty lines' + end if + end function count_lines_in_file_with_comments_ + + !> Mirrors load_data_file_with_comments exactly: dim is the comment-aware line + !> count; comment lines (containing '%', '#', or '!') are skipped. The loop + !> bound dimf is the raw line count (count_lines_in_file), preserving the + !> oracle's mix of the two counters. + function load_data_file_with_comments_(file_name, dim_, ncols, rgrid, qgrid) & + result(ierr) bind(C, name="load_data_file_with_comments") + character(kind=c_char), intent(in) :: file_name(*) + integer(c_int), value :: dim_, ncols + real(c_double), intent(out) :: rgrid(0:dim_ - 1) + real(c_double), intent(out) :: qgrid(0:dim_*ncols - 1) + integer(c_int) :: ierr + + character(len=1024) :: fname + integer :: unit, ios, i, k, ind, dimf + real(dp) :: vals(0:ncols) + character(len=65536) :: line + + fname = c_string_to_fortran(file_name) + + if (dim_ /= count_lines_in_file_with_comments_(file_name, 0_c_int)) then + write (*, '(a,a)') 'error: load_data_file: read error or false input '// & + 'data dimension: ', trim(fname) + stop 1 + end if + + open (newunit=unit, file=trim(fname), status='old', action='read', iostat=ios) + if (ios /= 0) then + write (*, '(a,a)') 'load_data_file: failed to open file ', trim(fname) + stop 1 + end if + + dimf = count_lines_in_file_(file_name, 0_c_int) + ind = 0 + do i = 0, dimf - 1 + read (unit, '(a)', iostat=ios) line + if (ios /= 0) then + write (*, '(a,a,a)') 'load_data_file: file ', trim(fname), & + ' reading error!' + stop 1 + end if + + if (index(line, '%') /= 0 .or. index(line, '#') /= 0 & + .or. index(line, '!') /= 0) cycle + + read (line, *, iostat=ios) vals(0:ncols) + if (ios /= 0) then + write (*, '(a,a,a)') 'error: load_data_file: ', trim(fname), & + ': read error or false data dimension!' + stop 1 + end if + + rgrid(ind) = vals(0) + do k = 0, ncols - 1 + qgrid(ind + k*dim_) = vals(k + 1) + end do + ind = ind + 1 + end do + + if (ind /= dim_) then + write (*, '(a,a,a)') 'error: load_data_file: ', trim(fname), & + ': read error or false data dimension!' + stop 1 + end if + + close (unit) + + ierr = 0 + end function load_data_file_with_comments_ + + !> Reads one line from a C FILE* via libc getline into a Fortran string, + !> stripping the trailing newline. nread is getline's return (-1 at EOF). + subroutine read_raw_line(stream, line, nread) + type(c_ptr), value :: stream + character(len=*), intent(out) :: line + integer(c_long), intent(out) :: nread + + type(c_ptr), target :: buf + integer(c_size_t), target :: nbytes + character(kind=c_char), pointer :: cbuf(:) + integer :: i, m + + buf = c_malloc(1024_c_size_t) + nbytes = 1024_c_size_t + nread = c_getline(c_loc(buf), c_loc(nbytes), stream) + + line = '' + if (nread > 0) then + m = int(nread) + call c_f_pointer(buf, cbuf, [m]) + do i = 1, m + if (cbuf(i) == c_null_char) exit + if (cbuf(i) == achar(10)) exit + if (i > len(line)) exit + line(i:i) = cbuf(i) + end do + end if + + call c_free(buf) + end subroutine read_raw_line + + !> Reads one line and returns the text before the first '#'. ok is false on a + !> short/failed read (getline < 2), matching the oracle's warning condition. + subroutine read_line_before_hash(stream, sub, ok) + type(c_ptr), value :: stream + character(len=*), intent(out) :: sub + logical, intent(out) :: ok + + character(len=4096) :: line + integer(c_long) :: nread + integer :: p + + call read_raw_line(stream, line, nread) + ok = nread >= 2 + p = index(line, '#') + if (p > 0) then + sub = line(1:p - 1) + else + sub = line + end if + end subroutine read_line_before_hash + + function c_string_to_fortran(cstr) result(fstr) + character(kind=c_char), intent(in) :: cstr(*) + character(len=1024) :: fstr + integer :: i + fstr = '' + i = 0 + do + if (cstr(i + 1) == c_null_char .or. i >= 1024) exit + fstr(i + 1:i + 1) = cstr(i + 1) + i = i + 1 + end do + end function c_string_to_fortran + +end module kilca_inout_m diff --git a/KiLCA/math/adapt_grid/adaptive_grid.cpp b/KiLCA/math/adapt_grid/adaptive_grid.cpp deleted file mode 100644 index 6d33b5ac..00000000 --- a/KiLCA/math/adapt_grid/adaptive_grid.cpp +++ /dev/null @@ -1,318 +0,0 @@ -/*! \file - \brief The implementation of functions declared in adaptive_grid.h. -*/ - -#include -#include - -#include "adaptive_grid.h" -#include "shared.h" - -/******************************************************************************/ - -void set_interval (struct interval5 *I, double x1, double x2, double y1, double y2, - void (*f)(double *, double *, void *p), void *p) -{ -I->xs = x1; -I->ys = y1; - -I->xe = x2; -I->ye = y2; - -I->xm = 0.5*(x1+x2); -f (&I->xm, &I->ym, p); - -I->xl = (3*x1+x2)/4.0; -f (&I->xl, &I->yl, p); - -I->xr = (x1+3*x2)/4.0; -f (&I->xr, &I->yr, p); -} - -/******************************************************************************/ - -void add_new_interval_to_the_array (interval5 *Iarr, int max_ind, int Icount, - void (*f)(double *, double *, void *p), void *p) -{ -//adds new interval at the end of the array (which is right part of the max_ind interval) -Iarr[Icount].xs = Iarr[max_ind].xm; -Iarr[Icount].ys = Iarr[max_ind].ym; - -Iarr[Icount].xe = Iarr[max_ind].xe; -Iarr[Icount].ye = Iarr[max_ind].ye; - -Iarr[Icount].xm = Iarr[max_ind].xr; -Iarr[Icount].ym = Iarr[max_ind].yr; - -Iarr[Icount].xl = (3*Iarr[Icount].xs+Iarr[Icount].xe)/4.0; -f (&Iarr[Icount].xl, &Iarr[Icount].yl, p); - -Iarr[Icount].xr = (Iarr[Icount].xs+3*Iarr[Icount].xe)/4.0; -f (&Iarr[Icount].xr, &Iarr[Icount].yr, p); -} - -/******************************************************************************/ - -void update_max_err_interval (interval5 *Iarr, int max_ind, - void (*f)(double *, double *, void *p), void *p) -{ -//modifies max_ind interval (set it to the left part of the max_ind interval) -Iarr[max_ind].xe = Iarr[max_ind].xm; -Iarr[max_ind].ye = Iarr[max_ind].ym; - -Iarr[max_ind].xm = Iarr[max_ind].xl; -Iarr[max_ind].ym = Iarr[max_ind].yl; - -Iarr[max_ind].xl = (3*Iarr[max_ind].xs+Iarr[max_ind].xe)/4.0; -f (&Iarr[max_ind].xl, &Iarr[max_ind].yl, p); - -Iarr[max_ind].xr = (Iarr[max_ind].xs+3*Iarr[max_ind].xe)/4.0; -f (&Iarr[max_ind].xr, &Iarr[max_ind].yr, p); -} - -/******************************************************************************/ - -inline void eval_error (interval5 *I, double *err) -{ -//computes absolute and relative error of the Simpson rule: -//double quad = (I->xe - I->xs)*fabs(I->ys + 4.0*I->ym + I->ye)/6.0; -//double rele = (I->xe - I->xs)*fabs(I->ys - 4.0*I->yl + 6.0*I->ym - 4.0*I->yr + I->ye); -//*err = fmin(rele/quad, rele); bad if quad == 0 -//*err = fmin(rele/(quad+DBL_EPSILON), rele); also not very good - -//computes absolute error of the Simpson rule: works good! -*err = fabs ((I->xe - I->xs)*fabs(I->ys - 4.0*I->yl + 6.0*I->ym - 4.0*I->yr + I->ye)); -} - -/******************************************************************************/ - -void calc_adaptive_1D_grid_ (void (*f)(double *, double *, void *p), void *p, - const int *max_dimx, double *eps, int *dimx, double *x, double *y) -{ -/* -finds adaptive 1D grid for the function func on the interval (x1, x2) -maximal allowed grid dimension max_dim, error for stopping criterion eps. -on input: initial grid (x, y) has dimension dimx. -on output: generated grid stored in (x, y) and dimension is set in dimx. -*/ - -int max_dimI = (*max_dimx-1)/4; //maximal allowed number of intervals, each has 4 grid points (+1) - -struct interval5 *Iarr = new struct interval5[max_dimI]; //array of intervals - -double *err = new double[max_dimI]; //array of errors - -int i; -for (i=0; i<*dimx-1; i++) -{ - set_interval (Iarr+i, x[i], x[i+1], y[i], y[i+1], f, p); //initial intervals - eval_error (Iarr+i, err+i); -} - -int dimI = *dimx-1; //number of elements in the array of intervals - -double max_err = 0.0; -int max_ind; - -while (dimI < max_dimI) -{ - //search for an interval with maximal error: - max_err = err[0]; - max_ind = 0; - - for (i=1; i max_err) - { - max_err = err[i]; - max_ind = i; - } - } - - if (max_err < *eps) break; - - //split max_ind interval: add a new one to the end and modify the max_ind interval - add_new_interval_to_the_array (Iarr, max_ind, dimI, f, p); - eval_error (Iarr+dimI, err+dimI); - dimI++; - - update_max_err_interval (Iarr, max_ind, f, p); - eval_error (Iarr+max_ind, err+max_ind); -} - -*eps = max_err; //the error reached dirung grid refinement - -for(i=0; i max_err) - { - max_err = err[i]; - max_ind = i; - } - } - - if (max_err < *eps) break; - - //split max_ind interval: add a new one to the end and modify the max_ind interval - add_new_interval_to_the_array (Iarr, max_ind, dimI, f, p); - eval_error (Iarr+dimI, err+dimI); - dimI++; - - update_max_err_interval (Iarr, max_ind, f, p); - eval_error (Iarr+max_ind, err+max_ind); - } - - *eps = max_err; //the error reached dirung grid refinement - - *dimx = 4*dimI+1; //number of evaluated grid points - - delete [] Iarr; - delete [] err; -} - -/******************************************************************************/ - -void check_and_remove_grid_condensations_ (double dx, int *dimx, double *x, double *y) -{ -//checks if there are condensations of points related with narrow peaks and remove them from the sorted grid -//(designed against the grid condensation in regions with a numerical noise in a data) - -int i, j, step; - -int k = 0; //cleaned array index - -for (i=0; i<*dimx; i+=step) -{ - if (k-i) //if there were condensed points - { - x[k] = x[i]; - y[k] = y[i]; - } - - step = 0; - for (j=i+1; j<*dimx; j++) - { - if (x[j]-x[i] > dx) - { - step = j-i; - if (step > 1) - { - fprintf (stderr, "\nwarning: calc_adaptive_1D_grid: grid condensation detected:\n %d points are found in interval [%.16le, %.16le].", step+1, x[i], x[j]); - } - break; - } - } - - k++; - - if (step == 0) - { - if (i < (*dimx)-1) //for the last array point step = 0 is Ok. - { - fprintf (stderr, "\nwarning: calc_adaptive_1D_grid: grid condensation detected:\n %d points are found in interval [%.16le, %.16le].", j-i, x[i], x[j-1]); - } - break; //there are no more points within x[i]+dx interval - } -} - -//new grid dimension: -*dimx = k; -} - -/******************************************************************************/ diff --git a/KiLCA/math/adapt_grid/adaptive_grid.h b/KiLCA/math/adapt_grid/adaptive_grid.h deleted file mode 100644 index 72364ea2..00000000 --- a/KiLCA/math/adapt_grid/adaptive_grid.h +++ /dev/null @@ -1,44 +0,0 @@ -/*! \file - \brief The declarations of functions for generation of adaptive grids according to simple estimate of accuracy. -*/ - -#ifndef ADA_GRID_INCLUDE - -#define ADA_GRID_INCLUDE - -struct interval5 -{ - double xs, ys; - double xl, yl; - double xm, ym; - double xr, yr; - double xe, ye; - double err; -}; - -//external: -extern "C" -{ -void calc_adaptive_1D_grid_ (void (*f)(double *, double *, void *p), void *p, - const int *max_dimx, double *eps, int *dimx, double *x, double *y); - -void calc_adaptive_1D_grid_4vector_ (void (*f)(double *, double *, void *p), void *p, - const int *max_dimx, double *eps, - int *dimx, const double *x, const double *y); -} - -//internal: -void set_interval (interval5 *I, double x1, double x2, double y1, double y2, - void (*f)(double *, double *, void *p), void *p); - -void add_new_interval_to_the_array (interval5 *Iarr, int max_ind, int Icount, - void (*f)(double *, double *, void *p), void *p); - -void update_max_err_interval (interval5 *Iarr, int max_ind, - void (*f)(double *, double *, void *p), void *p); - -inline void eval_error (interval5 *I, double *err); - -void check_and_remove_grid_condensations_ (double eps, int *dimx, double *x, double *y); - -#endif diff --git a/KiLCA/math/adapt_grid/adaptive_grid_m.f90 b/KiLCA/math/adapt_grid/adaptive_grid_m.f90 new file mode 100644 index 00000000..345f9ccf --- /dev/null +++ b/KiLCA/math/adapt_grid/adaptive_grid_m.f90 @@ -0,0 +1,176 @@ +!> Scalar adaptive 1D grid refinement, formerly +!> KiLCA/math/adapt_grid/adaptive_grid.cpp. Only the vector-valued entry +!> calc_adaptive_1D_grid_4vector_ is live: its sole caller is the Fortran +!> sysmat_profiles_create (kilca_sysmat_profiles_m), which reaches it through +!> a bind(C, name="calc_adaptive_1D_grid_4vector_") interface block, so the +!> C symbol name is preserved and that caller needs no change. +!> +!> The companion scalar entry calc_adaptive_1D_grid_ and its only helper +!> check_and_remove_grid_condensations_ had zero callers anywhere in KiLCA or +!> QL-Balance (verified by grep across all C++, header and Fortran sources); +!> they are dropped, matching this port's dead-code precedent. set_interval, +!> add_new_interval_to_the_array, update_max_err_interval and eval_error were +!> shared by both entries and survive as private helpers of the live one. +module adaptive_grid_m + use, intrinsic :: iso_c_binding, only: c_double, c_int, c_ptr, c_funptr, & + c_f_procpointer + implicit none + private + + public :: calc_adaptive_1D_grid_4vector + + type :: interval5_t + real(c_double) :: xs, ys + real(c_double) :: xl, yl + real(c_double) :: xm, ym + real(c_double) :: xr, yr + real(c_double) :: xe, ye + end type interval5_t + + abstract interface + subroutine sample_cb(r, fval, ctx) bind(C) + import :: c_double, c_ptr + real(c_double), intent(in) :: r + real(c_double), intent(out) :: fval + type(c_ptr), value :: ctx + end subroutine sample_cb + end interface + +contains + + !> The callback f writes one scalar accuracy proxy per evaluated abscissa + !> (it stores the full vector through p); x and y carry the initial grid on + !> input, and on output dimx holds the count of evaluated grid points while + !> eps holds the error reached. The grid itself is collected through p by + !> the callback, so this routine never sorts or emits it (unlike the + !> dropped scalar entry). + subroutine calc_adaptive_1D_grid_4vector(f, p, max_dimx, eps, dimx, x, y) & + bind(C, name="calc_adaptive_1D_grid_4vector_") + type(c_funptr), value :: f + type(c_ptr), value :: p + integer(c_int), intent(in) :: max_dimx + real(c_double), intent(inout) :: eps + integer(c_int), intent(inout) :: dimx + real(c_double), intent(in) :: x(0:*) + real(c_double), intent(in) :: y(0:*) + + procedure(sample_cb), pointer :: cb + type(interval5_t), allocatable :: Iarr(:) + real(c_double), allocatable :: err(:) + integer(c_int) :: max_dimI, dimI, i, max_ind + real(c_double) :: max_err + + call c_f_procpointer(f, cb) + + max_dimI = (max_dimx - 1)/4 + + allocate (Iarr(0:max_dimI - 1)) + allocate (err(0:max_dimI - 1)) + + do i = 0, dimx - 2 + call set_interval(Iarr(i), x(i), x(i + 1), y(i), y(i + 1), cb, p) + call eval_error(Iarr(i), err(i)) + end do + + dimI = dimx - 1 + max_err = 0.0_c_double + + do while (dimI < max_dimI) + max_err = err(0) + max_ind = 0 + + do i = 1, dimI - 1 + if (err(i) > max_err) then + max_err = err(i) + max_ind = i + end if + end do + + if (max_err < eps) exit + + call add_new_interval_to_the_array(Iarr, max_ind, dimI, cb, p) + call eval_error(Iarr(dimI), err(dimI)) + dimI = dimI + 1 + + call update_max_err_interval(Iarr, max_ind, cb, p) + call eval_error(Iarr(max_ind), err(max_ind)) + end do + + eps = max_err + dimx = 4*dimI + 1 + end subroutine calc_adaptive_1D_grid_4vector + + subroutine set_interval(iv, x1, x2, y1, y2, cb, p) + type(interval5_t), intent(inout) :: iv + real(c_double), intent(in) :: x1, x2, y1, y2 + procedure(sample_cb) :: cb + type(c_ptr), value :: p + + iv%xs = x1 + iv%ys = y1 + + iv%xe = x2 + iv%ye = y2 + + iv%xm = 0.5_c_double*(x1 + x2) + call cb(iv%xm, iv%ym, p) + + iv%xl = (3.0_c_double*x1 + x2)/4.0_c_double + call cb(iv%xl, iv%yl, p) + + iv%xr = (x1 + 3.0_c_double*x2)/4.0_c_double + call cb(iv%xr, iv%yr, p) + end subroutine set_interval + + subroutine add_new_interval_to_the_array(Iarr, max_ind, Icount, cb, p) + type(interval5_t), intent(inout) :: Iarr(0:*) + integer(c_int), intent(in) :: max_ind, Icount + procedure(sample_cb) :: cb + type(c_ptr), value :: p + + Iarr(Icount)%xs = Iarr(max_ind)%xm + Iarr(Icount)%ys = Iarr(max_ind)%ym + + Iarr(Icount)%xe = Iarr(max_ind)%xe + Iarr(Icount)%ye = Iarr(max_ind)%ye + + Iarr(Icount)%xm = Iarr(max_ind)%xr + Iarr(Icount)%ym = Iarr(max_ind)%yr + + Iarr(Icount)%xl = (3.0_c_double*Iarr(Icount)%xs + Iarr(Icount)%xe)/4.0_c_double + call cb(Iarr(Icount)%xl, Iarr(Icount)%yl, p) + + Iarr(Icount)%xr = (Iarr(Icount)%xs + 3.0_c_double*Iarr(Icount)%xe)/4.0_c_double + call cb(Iarr(Icount)%xr, Iarr(Icount)%yr, p) + end subroutine add_new_interval_to_the_array + + subroutine update_max_err_interval(Iarr, max_ind, cb, p) + type(interval5_t), intent(inout) :: Iarr(0:*) + integer(c_int), intent(in) :: max_ind + procedure(sample_cb) :: cb + type(c_ptr), value :: p + + Iarr(max_ind)%xe = Iarr(max_ind)%xm + Iarr(max_ind)%ye = Iarr(max_ind)%ym + + Iarr(max_ind)%xm = Iarr(max_ind)%xl + Iarr(max_ind)%ym = Iarr(max_ind)%yl + + Iarr(max_ind)%xl = (3.0_c_double*Iarr(max_ind)%xs + Iarr(max_ind)%xe) & + /4.0_c_double + call cb(Iarr(max_ind)%xl, Iarr(max_ind)%yl, p) + + Iarr(max_ind)%xr = (Iarr(max_ind)%xs + 3.0_c_double*Iarr(max_ind)%xe) & + /4.0_c_double + call cb(Iarr(max_ind)%xr, Iarr(max_ind)%yr, p) + end subroutine update_max_err_interval + + subroutine eval_error(iv, err) + type(interval5_t), intent(in) :: iv + real(c_double), intent(out) :: err + + err = abs((iv%xe - iv%xs)*abs(iv%ys - 4.0_c_double*iv%yl + 6.0_c_double*iv%ym & + - 4.0_c_double*iv%yr + iv%ye)) + end subroutine eval_error + +end module adaptive_grid_m diff --git a/KiLCA/math/adapt_grid/adaptive_grid_pol.cpp b/KiLCA/math/adapt_grid/adaptive_grid_pol.cpp deleted file mode 100644 index 4286739c..00000000 --- a/KiLCA/math/adapt_grid/adaptive_grid_pol.cpp +++ /dev/null @@ -1,821 +0,0 @@ -/*! \file - \brief The implementation of functions declared in adaptive_grid_pol.h. -*/ - -#include -#include -#include -#include -#include -#include - -#include "adaptive_grid_pol.h" - -/*****************************************************************************/ - -int adaptive_grid_polynom (void (*func)(double *, double *, void *p), void *p, - double a, double b, int dimy, int deg, int *xdim, double *eps, - double *x1, double *y1) -{ -//makes an adaptive x grid for moving interpolating polynoma of degree deg -//better to use odd degrees - -//additional space: -double *x2 = new double[(*xdim)]; -double *y2 = new double[(*xdim)*dimy]; - -double *xold = x1, *yold = y1, *xnew = x2, *ynew = y2; - -//initial grid: for 3 "moving" polynoma -int dimx = deg + 3; - -xold[0] = a; -xold[dimx-1] = b; - -double pi = 3.141592653589793238; - -for (int k=1; k<=deg+1; k++) //Chebishev nodes -{ - xold[k] = 0.5*(a+b) - 0.5*(b-a)*cos((2*k-1)*pi/(2*(deg+1))); -} - -//initial y grid: -for (int k=0; k 1.0e-16) errt = min (errt, errt/abs(ym[j])); - if (abs(ym[j]) > 1.0) errt /= abs(ym[j]); - - if (errt > merr) //maximum error and its location - { - merr = errt; - xmerr = xc; - ymerr = ym[j]; - jmerr = j; - } - - //checks values of errors: - //if (!((errl < (*eps) || errl < err) && (errr < (*eps) || errr < err))) - //{ - // flag = 1; - //} - if (errt > *eps) flag = 1; //add the point to the grid - } - - //check xnew for dimension: - if (node >= *xdim-2) - { - if (DEBUG_FLAG) - { - fprintf (stdout, "\n\nadaptive_grid_polynom: warning: maximum dimension is reached: node=%d: exit with the previous grid.", node); - fflush (stdout); - } - - if (x1 != xold) - { - for (int m=0; m 1.0) errt /= abs(ym[l]); - - if (errt > merr) //maximum error and its location - { - merr = errt; - xmerr = xc; - ymerr = ym[l]; - jmerr = j; - } - - err = *eps; - - if (errt > err) flag = 1; //flag to add the point - } - - //check xnew for dimension: - if (node >= *xdim-2) - { - if (DEBUG_FLAG) - { - fprintf (stdout, "\n\nadaptive_grid_polynom: warning: maximum dimension is reached: node=%d: exit with the previous grid.", node); - fflush (stdout); - } - - if (x1 != xold) - { - for (int m=0; m 1.0) errt /= abs(ym[l]); - - if (errt > merr) //maximum error and its location - { - merr = errt; - xmerr = xc; - ymerr = ym[l]; - jmerr = j; - } - - //change the error in resonance zone: - err = (*eps-eps_res)*(1.0 - exp(-(xc-r_res)*(xc-r_res)/D/D)) + eps_res; - - if (errt > err) flag = 1; //flag to add the point - } - - //check xnew for dimension: - if (node >= *xdim-2) - { - if (DEBUG_FLAG) - { - fprintf (stdout, "\n\nadaptive_grid_polynom: warning: maximum dimension is reached: node=%d: exit with the previous grid.", node); - fflush (stdout); - } - - if (x1 != xold) - { - for (int m=0; m 1.0e-16) errt = min (errt, errt/abs(yc)); - - if (errt > merr) //maximum error and its location - { - merr = errt; - xmerr = xc; - ymerr = yc; - jmerr = j; - } - - //checks values of errors: - if (!(erra < (*eps_a) || erra < errr) || xc-xold[k] > step) - { - flag = 1; - } - } - - if (!flag) continue; //accuracy is good: go to the next point in the old grid - - //adds new xc point to the new grid - xnew[node] = xc; - inew[node] = ic; - func_interp (ic, ynew+node*dimy, x, xdim, y, dimy); - node++; - } - - //add last grid point (b): k=dimx-1 - xnew[node] = xold[dimx-1]; - inew[node] = iold[dimx-1]; - for (int j=0; j -#include -#include -#include -#include -#include - -#include "code_settings.h" - -using namespace std; - -#ifndef ADA_GRID_POLYNOM_INCLUDE - -#define ADA_GRID_POLYNOM_INCLUDE - -/*****************************************************************************/ - -int adaptive_grid_polynom (void (*func)(double *, double *, void *p), void *p, - double a, double b, int dimy, int deg, int *xdim, double *eps, - double *x1, double *y1); - -int adaptive_grid_polynom (void (*func)(double *, double *, void *p), void *p, - double a, double b, int dimy, int deg, int *xdim, double *eps, - int dim_err, int *ind_err, double *x1, double *y1); - -int adaptive_grid_polynom_res (void (*func)(double *, double *, void *p), void *p, - double a, double b, int dimy, int deg, int *xdim, double *eps, - double r_res, double D, double eps_res, - int dim_err, int *ind_err, double *x1, double *y1); - -int sparse_grid_polynom (double *x, int dimx, double *y, int dimy, int deg, double *eps_a, - double *eps_r, double step, int *dim, double *x1, double *y1, int *ind1); - -inline void eval_interp_polynom (int deg, double *xg, double *yg, int dimy, double x, double *y); - -inline void find_index_for_interp (int deg, double x, int dimx, const double *xa, int *ind); - -inline void search_array (double x, int dimx, const double *xa, int *ind); - -inline int binary_search (double x, const double *xa, int ilo, int ihi); - -inline int sign (double x); - -void inline func_interp (int ind, double *yout, double *x, int dimx, double *y, int dimy); - -inline void eval_neville_polynom (const double *xa, const double *ya, - int yshift, int deg, double x, double *R); - -/*****************************************************************************/ - -#endif - -/*****************************************************************************/ - -inline void eval_interp_polynom (int deg, double *xg, double *yg, int dimy, double x, double *y) -{ -for (int j=0; j=xa[dim-1] - Ok for splines and interpolation -//be careful to change something here: -if (x < xa[*ind]) -{ - *ind = binary_search (x, xa, 0, *ind); -} -else if (x >= xa[*ind+1]) -{ - *ind = binary_search (x, xa, *ind, dimx-1); -} -else -{} -} - -/*****************************************************************************/ - -inline int binary_search (double x, const double *xa, int ilo, int ihi) -{ -//warning: returns dim-2 for x>=xa[dim-1] - Ok for splines! -while (ihi > ilo+1) -{ - int i = (ihi+ilo)/2; - if (xa[i] > x) ihi = i; - else ilo = i; -} -return ilo; -} - -/*****************************************************************************/ - -inline int sign (double x) -{ -return (x<0.0) ? (-1):((x==0) ? 0:1); -} - -/*****************************************************************************/ - -inline void eval_neville_polynom (const double *xa, const double *ya, int yshift, int deg, double x, double *R) -{ -/* -if (x < xa[0] || x > xa[deg]) -{ - fprintf (stdout, "\nwarning: eval_neville_polynom: x is outside the array [%le, %le]: x=%le", xa[0], xa[deg], x); -} -*/ - -double p[deg+1][deg+1]; - -for (int d=0; d<=deg; d++) p[d][d] = ya[d*yshift]; - -for (int d=1; d<=deg; d++) //over polymomial order -{ - for (int i=0; i<=deg-d; i++) - { - int j = i + d; - - p[i][j] = ((x-xa[j])/(xa[i]-xa[j]))*p[i][j-1]-((x-xa[i])/(xa[i]-xa[j]))*p[i+1][j]; - } -} - -*R = p[0][deg]; -} - -/*****************************************************************************/ diff --git a/KiLCA/math/adapt_grid/adaptive_grid_pol_m.f90 b/KiLCA/math/adapt_grid/adaptive_grid_pol_m.f90 new file mode 100644 index 00000000..9549d60f --- /dev/null +++ b/KiLCA/math/adapt_grid/adaptive_grid_pol_m.f90 @@ -0,0 +1,401 @@ +!> Vector-valued adaptive 1D grid refinement by moving polynomial +!> interpolation, formerly KiLCA/math/adapt_grid/adaptive_grid_pol.cpp. The two +!> live entry points are adaptive_grid_polynom_res and adaptive_grid_polynom_err, +!> both called by the Fortran conductivity-grid generator (kilca_cond_profiles_m) +!> through bind(C) interface blocks, so the C symbol names are preserved. +!> +!> Dropped as dead (verified by grep across all C++, header and Fortran +!> sources): +!> - the two-overload adaptive_grid_polynom: the dimy/no-ind_err overload is +!> reached only from the orphaned demo main_agp.cpp (in no CMake target); +!> the dim_err/ind_err overload had exactly one caller, the thin extern "C" +!> adaptive_grid_polynom_err forwarder, whose algorithm body is therefore +!> folded directly into adaptive_grid_polynom_err here. +!> - sparse_grid_polynom and its helpers eval_interp_polynom/func_interp were +!> already ported (kilca_interp_m) and have no caller of this file's copies. +!> - sign was never called. +!> - the DEBUG_FLAG (compile-time 0) and local debug (always 0) warning prints +!> never executed, so their dead branches and the xmerr/ymerr/jmerr trace +!> variables that only fed them are omitted. +!> +!> find_index_for_interp/search_array/binary_search and this file's own +!> yshift-strided eval_neville_polynom (distinct from kilca_neville_m's +!> Dmin/Dmax variant) are kept as private helpers. The C++ pointer-swap between +!> (xold,yold) and (xnew,ynew) plus the "if (x1 != xold)" skip-copy is a +!> memory-reuse detail with no numerical effect; here the swap uses move_alloc +!> and the result is always copied into the caller's x1/y1. +module adaptive_grid_pol_m + use, intrinsic :: iso_c_binding, only: c_double, c_int, c_ptr, c_funptr, & + c_f_procpointer + implicit none + private + + public :: adaptive_grid_polynom_res, adaptive_grid_polynom_err + public :: find_index_for_interp, eval_neville_polynom + + abstract interface + subroutine sample_cb(r, fval, ctx) bind(C) + import :: c_double, c_ptr + real(c_double), intent(in) :: r + real(c_double), intent(out) :: fval(*) + type(c_ptr), value :: ctx + end subroutine sample_cb + end interface + +contains + + !> Refines a Chebyshev-seeded grid until, for each component listed in + !> ind_err, the error of the central moving polynomial against its left and + !> right neighbours falls below eps. Returns 0 on convergence, 1 if the + !> buffer dimension xdim was reached first (then the previous grid and its + !> error are restored). Body folded from the C++ dim_err overload of + !> adaptive_grid_polynom that the extern "C" forwarder called. + function adaptive_grid_polynom_err(f, p, a, b, dimy, deg, xdim, eps, & + dim_err, ind_err, x1, y1) result(stat) & + bind(C, name="adaptive_grid_polynom_err") + type(c_funptr), value :: f + type(c_ptr), value :: p + real(c_double), value :: a, b + integer(c_int), value :: dimy, deg, dim_err + integer(c_int), intent(inout) :: xdim + real(c_double), intent(inout) :: eps + integer(c_int), intent(in) :: ind_err(0:*) + real(c_double), intent(inout) :: x1(0:*), y1(0:*) + integer(c_int) :: stat + + procedure(sample_cb), pointer :: cb + real(c_double), allocatable :: xold(:), xnew(:), yold(:), ynew(:) + real(c_double), allocatable :: yl(:), ym(:), yr(:) + integer(c_int) :: maxdim, dimx, k, j, l, ind, indl, indr, node, m, jj, flag + real(c_double) :: pi, xc, errl, errr, errt, merr, peps, err + + call c_f_procpointer(f, cb) + + maxdim = xdim + + allocate (xold(0:maxdim - 1), xnew(0:maxdim - 1)) + allocate (yold(0:maxdim*dimy - 1), ynew(0:maxdim*dimy - 1)) + allocate (yl(0:dim_err - 1), ym(0:dim_err - 1), yr(0:dim_err - 1)) + + dimx = deg + 3 + + xold(0) = a + xold(dimx - 1) = b + + pi = 3.141592653589793238_c_double + + do k = 1, deg + 1 + xold(k) = 0.5_c_double*(a + b) - 0.5_c_double*(b - a) & + *cos(real(2*k - 1, c_double)*pi/real(2*(deg + 1), c_double)) + end do + + do k = 0, dimx - 1 + call cb(xold(k), yold(k*dimy), p) + end do + + merr = 0.0_c_double + + do + ind = 0 + node = 0 + + peps = merr + merr = 0.0_c_double + + do k = 0, dimx - 2 + xnew(node) = xold(k) + do j = 0, dimy - 1 + ynew(node*dimy + j) = yold(k*dimy + j) + end do + node = node + 1 + + xc = xold(k) + 0.5_c_double*(xold(k + 1) - xold(k)) + + call find_index_for_interp(deg, xc, dimx, xold, ind) + + indl = max(0, ind - 1) + indr = min(ind + 1, dimx - deg - 1) + + flag = 0 + + do l = 0, dim_err - 1 + j = ind_err(l) + + call eval_neville_polynom(xold(ind), yold(ind*dimy + j), & + dimy, deg, xc, ym(l)) + call eval_neville_polynom(xold(indl), yold(indl*dimy + j), & + dimy, deg, xc, yl(l)) + call eval_neville_polynom(xold(indr), yold(indr*dimy + j), & + dimy, deg, xc, yr(l)) + + errl = abs(yl(l) - ym(l)) + errr = abs(yr(l) - ym(l)) + + errt = max(errl, errr) + + if (abs(ym(l)) > 1.0_c_double) errt = errt/abs(ym(l)) + + if (errt > merr) merr = errt + + err = eps + + if (errt > err) flag = 1 + end do + + if (node >= maxdim - 2) then + do m = 0, dimx - 1 + x1(m) = xold(m) + do jj = 0, dimy - 1 + y1(m*dimy + jj) = yold(m*dimy + jj) + end do + end do + xdim = dimx + eps = peps + stat = 1 + return + end if + + if (flag == 0) cycle + + xnew(node) = xc + call cb(xnew(node), ynew(node*dimy), p) + node = node + 1 + end do + + xnew(node) = xold(dimx - 1) + do j = 0, dimy - 1 + ynew(node*dimy + j) = yold((dimx - 1)*dimy + j) + end do + node = node + 1 + + call swap_real(xold, xnew) + call swap_real(yold, ynew) + + if (node == dimx) exit + + dimx = node + end do + + do m = 0, dimx - 1 + x1(m) = xold(m) + do jj = 0, dimy - 1 + y1(m*dimy + jj) = yold(m*dimy + jj) + end do + end do + + xdim = dimx + eps = merr + stat = 0 + end function adaptive_grid_polynom_err + + !> Same refinement as adaptive_grid_polynom_err, but the per-point error + !> threshold is relaxed away from the resonance radius r_res by a Gaussian + !> of width D, dropping to eps_res at r_res and rising to eps far from it. + function adaptive_grid_polynom_res(f, p, a, b, dimy, deg, xdim, eps, & + r_res, D, eps_res, dim_err, ind_err, x1, y1) & + result(stat) bind(C, name="adaptive_grid_polynom_res") + type(c_funptr), value :: f + type(c_ptr), value :: p + real(c_double), value :: a, b, r_res, D, eps_res + real(c_double), intent(inout) :: eps + integer(c_int), value :: dimy, deg, dim_err + integer(c_int), intent(inout) :: xdim + integer(c_int), intent(in) :: ind_err(0:*) + real(c_double), intent(inout) :: x1(0:*), y1(0:*) + integer(c_int) :: stat + + procedure(sample_cb), pointer :: cb + real(c_double), allocatable :: xold(:), xnew(:), yold(:), ynew(:) + real(c_double), allocatable :: yl(:), ym(:), yr(:) + integer(c_int) :: maxdim, dimx, k, j, l, ind, indl, indr, node, m, jj, flag + real(c_double) :: pi, xc, errl, errr, errt, merr, peps, err + + call c_f_procpointer(f, cb) + + maxdim = xdim + + allocate (xold(0:maxdim - 1), xnew(0:maxdim - 1)) + allocate (yold(0:maxdim*dimy - 1), ynew(0:maxdim*dimy - 1)) + allocate (yl(0:dim_err - 1), ym(0:dim_err - 1), yr(0:dim_err - 1)) + + dimx = deg + 3 + + xold(0) = a + xold(dimx - 1) = b + + pi = 3.141592653589793238_c_double + + do k = 1, deg + 1 + xold(k) = 0.5_c_double*(a + b) - 0.5_c_double*(b - a) & + *cos(real(2*k - 1, c_double)*pi/real(2*(deg + 1), c_double)) + end do + + do k = 0, dimx - 1 + call cb(xold(k), yold(k*dimy), p) + end do + + merr = 0.0_c_double + + do + ind = 0 + node = 0 + + peps = merr + merr = 0.0_c_double + + do k = 0, dimx - 2 + xnew(node) = xold(k) + do j = 0, dimy - 1 + ynew(node*dimy + j) = yold(k*dimy + j) + end do + node = node + 1 + + xc = xold(k) + 0.5_c_double*(xold(k + 1) - xold(k)) + + call find_index_for_interp(deg, xc, dimx, xold, ind) + + indl = max(0, ind - 1) + indr = min(ind + 1, dimx - deg - 1) + + flag = 0 + + do l = 0, dim_err - 1 + j = ind_err(l) + + call eval_neville_polynom(xold(ind), yold(ind*dimy + j), & + dimy, deg, xc, ym(l)) + call eval_neville_polynom(xold(indl), yold(indl*dimy + j), & + dimy, deg, xc, yl(l)) + call eval_neville_polynom(xold(indr), yold(indr*dimy + j), & + dimy, deg, xc, yr(l)) + + errl = abs(yl(l) - ym(l)) + errr = abs(yr(l) - ym(l)) + + errt = max(errl, errr) + + if (abs(ym(l)) > 1.0_c_double) errt = errt/abs(ym(l)) + + if (errt > merr) merr = errt + + err = (eps - eps_res)*(1.0_c_double & + - exp(-(xc - r_res)*(xc - r_res)/D/D)) + eps_res + + if (errt > err) flag = 1 + end do + + if (node >= maxdim - 2) then + do m = 0, dimx - 1 + x1(m) = xold(m) + do jj = 0, dimy - 1 + y1(m*dimy + jj) = yold(m*dimy + jj) + end do + end do + xdim = dimx + eps = peps + stat = 1 + return + end if + + if (flag == 0) cycle + + xnew(node) = xc + call cb(xnew(node), ynew(node*dimy), p) + node = node + 1 + end do + + xnew(node) = xold(dimx - 1) + do j = 0, dimy - 1 + ynew(node*dimy + j) = yold((dimx - 1)*dimy + j) + end do + node = node + 1 + + call swap_real(xold, xnew) + call swap_real(yold, ynew) + + if (node == dimx) exit + + dimx = node + end do + + do m = 0, dimx - 1 + x1(m) = xold(m) + do jj = 0, dimy - 1 + y1(m*dimy + jj) = yold(m*dimy + jj) + end do + end do + + xdim = dimx + eps = merr + stat = 0 + end function adaptive_grid_polynom_res + + subroutine swap_real(u, v) + real(c_double), allocatable, intent(inout) :: u(:), v(:) + real(c_double), allocatable :: t(:) + call move_alloc(u, t) + call move_alloc(v, u) + call move_alloc(t, v) + end subroutine swap_real + + subroutine find_index_for_interp(deg, x, dimx, xa, ind) + integer(c_int), intent(in) :: deg, dimx + real(c_double), intent(in) :: x, xa(0:*) + integer(c_int), intent(inout) :: ind + ind = min(ind + (deg - 1)/2, dimx - 2) + call search_array(x, dimx, xa, ind) + ind = min(max(0, ind - (deg - 1)/2), dimx - deg - 1) + end subroutine find_index_for_interp + + subroutine search_array(x, dimx, xa, ind) + real(c_double), intent(in) :: x, xa(0:*) + integer(c_int), intent(in) :: dimx + integer(c_int), intent(inout) :: ind + if (x < xa(ind)) then + ind = binary_search(x, xa, 0, ind) + else if (x >= xa(ind + 1)) then + ind = binary_search(x, xa, ind, dimx - 1) + end if + end subroutine search_array + + function binary_search(x, xa, ilo, ihi) result(res) + real(c_double), intent(in) :: x, xa(0:*) + integer(c_int), intent(in) :: ilo, ihi + integer(c_int) :: res, lo, hi, i + lo = ilo + hi = ihi + do while (hi > lo + 1) + i = (hi + lo)/2 + if (xa(i) > x) then + hi = i + else + lo = i + end if + end do + res = lo + end function binary_search + + !> Neville interpolation of one component sampled with stride yshift: + !> R = value at x of the degree-deg polynomial through xa(0:deg) and + !> ya(0), ya(yshift), ..., ya(deg*yshift). + subroutine eval_neville_polynom(xa, ya, yshift, deg, x, R) + real(c_double), intent(in) :: xa(0:*), ya(0:*) + integer(c_int), intent(in) :: yshift, deg + real(c_double), intent(in) :: x + real(c_double), intent(out) :: R + real(c_double) :: pp(0:deg, 0:deg) + integer(c_int) :: d, i, j + do d = 0, deg + pp(d, d) = ya(d*yshift) + end do + do d = 1, deg + do i = 0, deg - d + j = i + d + pp(i, j) = ((x - xa(j))/(xa(i) - xa(j)))*pp(i, j - 1) & + - ((x - xa(i))/(xa(i) - xa(j)))*pp(i + 1, j) + end do + end do + R = pp(0, deg) + end subroutine eval_neville_polynom + +end module adaptive_grid_pol_m diff --git a/KiLCA/math/adapt_grid/main_agp.cpp b/KiLCA/math/adapt_grid/main_agp.cpp deleted file mode 100644 index 89ee519f..00000000 --- a/KiLCA/math/adapt_grid/main_agp.cpp +++ /dev/null @@ -1,97 +0,0 @@ -#include -#include -#include -#include -#include -#include - -#include "adaptive_grid_pol.h" - -using namespace std; - -/*****************************************************************************/ - -void test1(double *x, double *y, void *p); - -/*****************************************************************************/ - -int main(void) -{ -double a = 0.0; -double b = 60.0; - -int dimy = 3; -int xdim = 1000; - -int deg = 9; -double eps = 1.0e-12; - -double *x = new double[xdim]; -double *y = new double[dimy*xdim]; - -adaptive_grid_polynom (&test1, NULL, a, b, dimy, deg, &xdim, &eps, x, y); - -FILE *out; -if (!(out = fopen ("resgrid.dat", "w"))) -{ - fprintf (stderr, "\nFailed to open file\a\n"); -} - -for (int k=0; k -#include -#include -#include -#include - -#include "fortnum.h" -#include "constants.h" - -using namespace std; - -/*******************************************************************/ - -extern "C" -{ -int hypergeometric1f1_quad_ (double *b_re, double *b_im, double *z_re, double *z_im, double *f_re, double *f_im); - -int hypergeometric1f1_kummer_nmax_ (double *b_re, double *b_im, double *z_re, double *z_im, double *f_re, double *f_im); - -int hypergeometric1f1_kummer_ada_ (double *b_re, double *b_im, double *z_re, double *z_im, double *f_re, double *f_im); - -int hypergeometric1f1_kummer_modified_0_nmax_ (double *b_re, double *b_im, double *z_re, double *z_im, double *f_re, double *f_im); - -int hypergeometric1f1_kummer_modified_0_ada_ (double *b_re, double *b_im, double *z_re, double *z_im, double *f_re, double *f_im); - -int hypergeometric1f1_cont_fract_1_modified_0_ada_ (double *b_re, double *b_im, double *z_re, double *z_im, double *f_re, double *f_im); - -int hypergeometric1f1_kummer_modified_1_ (double *b_re, double *b_im, double *z_re, double *z_im, double *f_re, double *f_im); - -int hypergeometric1f1_cont_fract_1_dir_ (double *b_re, double *b_im, double *z_re, double *z_im, double *f_re, double *f_im); - -int hypergeometric1f1_cont_fract_1_inv_nmax_ (double *b_re, double *b_im, double *z_re, double *z_im, double *f_re, double *f_im); - -int hypergeometric1f1_cont_fract_1_inv_ada_ (double *b_re, double *b_im, double *z_re, double *z_im, double *f_re, double *f_im); -} - -/*******************************************************************/ - -int hypergeometric1f1_quad_ (double *b_re, double *b_im, double *z_re, double *z_im, double *f_re, double *f_im) -{ -//computes function 1F1(a,b,z) for a = 1 and complex b & z - -complex b(*b_re, *b_im), z(*z_re, *z_im); - -fortnum_complex result; -fortnum_hyperg_1f1_a1 (b, z, &result); - -*f_re = result.real(); -*f_im = result.imag(); - -return 0; -} - -/*******************************************************************/ - -int hypergeometric1f1_kummer_nmax_ (double *b_re, double *b_im, double *z_re, double *z_im, double *f_re, double *f_im) -{ -//computes function 1F1(a,b,z) for a = 1 and complex b & z by kummer series - -complex b(*b_re, *b_im), z(*z_re, *z_im); - -long int N = (int) ceil(-20.0/log10(abs(z/b))) + 5; - -//fprintf (stdout, "\nhypergeometric1f1_kummer: N = %ld", N); - -if (N < 1 || N > 1e6) -{ - fprintf (stdout, "\nwarning: hypergeometric1F1_kummer: N=%ld", N); - fprintf (stdout, "\nb=%le %le\nz=%le %le\nabs(z/b)=%le", real(b), imag(b), real(z), imag(z),abs(z/b)); -} - -complex term = z/(b+(double)N); - -for (long int n=N-1; n>=0; n--) -{ - term = 1.0 + z/(b+(double)n)*term; -} - -*f_re = real(term); -*f_im = imag(term); - -return 0; -} - -/*******************************************************************/ - -int hypergeometric1f1_kummer_ada_ (double *b_re, double *b_im, double *z_re, double *z_im, double *f_re, double *f_im) -{ -//computes function 1F1(a,b,z) for a = 1 and complex b & z by kummer series - -complex b(*b_re, *b_im), z(*z_re, *z_im); - -complex term, S1, S2; -double err, eps = DBL_EPSILON; -long int n, Nmax, maxNmax = 1e8; - -for (Nmax=4; Nmax=0; n--) - { - term = 1.0 + z/(b+(double)n)*term; - } - - S1 = term; - - n = Nmax+1; - term = z/(b+(double)n); - - for (n=Nmax; n>=0; n--) - { - term = 1.0 + z/(b+(double)n)*term; - } - - S2 = term; - - err = min (abs((S2-S1)/S2), abs(S2-S1)); - if (err < eps) break; -} - -//fprintf (stdout, "\nhypergeometric1f1_kummer_ada: Nmax = %ld err = %le\nS2 = %.20le %.20le", Nmax, err, real(S2), imag(S2)); - -if (Nmax >= maxNmax) -{ - fprintf (stderr, "\nwarning: hypergeometric1f1_kummer_ada: Nmax = %ld err = %le\nS2 = %le %le", Nmax, err, real(S2), imag(S2)); - fprintf (stderr, "\nb = %le %le z = %le %le", real(b), imag(b), real(z), imag(z)); -} - -*f_re = real(S2); -*f_im = imag(S2); - -return 0; -} - -/*******************************************************************/ - -int hypergeometric1f1_kummer_modified_1_ (double *b_re, double *b_im, double *z_re, double *z_im, double *f_re, double *f_im) -{ -//computes modified function 1F1m(a,b,z) for a = 1 and complex b & z by kummer series -//1F1 = 1 + z/b + z^2/b/(b+1)*1F1m - -complex b(*b_re, *b_im), z(*z_re, *z_im); - -long int N = (int) ceil(-20.0/log10(abs(z/b))) + 5; - -if (N < 1 || N > 1e6) -{ - fprintf (stdout, "\nwarning: hypergeometric1F1_kummer: N=%ld", N); - fprintf (stdout, "\nb=%le %le\nz=%le %le\nabs(z/b)=%le", real(b), imag(b), real(z), imag(z),abs(z/b)); -} - -complex term = z/(b+(double)N); - -for (long int n=N-1; n>=2; n--) -{ - term = 1.0 + z/(b+(double)n)*term; -} - -*f_re = real(term); -*f_im = imag(term); - -return 0; -} - -/*******************************************************************/ - -int hypergeometric1f1_kummer_modified_0_nmax_ (double *b_re, double *b_im, double *z_re, double *z_im, double *f_re, double *f_im) -{ -//computes modified function 1F1m(a,b,z) for a = 1 and complex b & z by kummer series -//1F1 = 1 + z/b + z^2/b/(b+1)*(1 + 1F1m) - -complex b(*b_re, *b_im), z(*z_re, *z_im); - -long int N = (long int) ceil(-20.0/log10(abs(z/b))) + 5; - -if (N < 1 || N > 1e6) -{ - fprintf (stdout, "\nwarning: hypergeometric1F1_kummer: N=%ld", N); - fprintf (stdout, "\nb=%le %le\nz=%le %le\nabs(z/b)=%le", real(b), imag(b), real(z), imag(z),abs(z/b)); -} - -complex term = z/(b+(double)N); - -for (long int n=N-1; n>2; n--) -{ - term = 1.0 + z/(b+(double)n)*term; -} - -term *= z/(b+2.0); - -*f_re = real(term); -*f_im = imag(term); - -return 0; -} - -/*******************************************************************/ - -int hypergeometric1f1_kummer_modified_0_ada_ (double *b_re, double *b_im, double *z_re, double *z_im, double *f_re, double *f_im) -{ -//computes modified function 1F1m(a,b,z) for a = 1 and complex b & z by kummer series -//1F1 = 1 + z/b + z^2/b/(b+1)*(1 + 1F1m) - -complex b(*b_re, *b_im), z(*z_re, *z_im); - -complex term, S1, S2; -double err, eps = DBL_EPSILON; -long int n, Nmax, maxNmax = 1e8; - -for (Nmax=4; Nmax2; n--) - { - term = 1.0 + (z/(b+(double)n))*term; - } - - S1 = term*(z/(b+2.0)); - - n = Nmax+1; - term = z/(b+(double)n); - - for (n=Nmax; n>2; n--) - { - term = 1.0 + (z/(b+(double)n))*term; - } - - S2 = term*(z/(b+2.0)); - - //err = min (abs((S2-S1)/S2), abs(S2-S1)); - err = abs((S2-S1)/S2); - - if (err < eps) break; -} - -if (Nmax >= maxNmax) -{ - fprintf (stderr, "\nwarning: hypergeometric1f1_kummer_modified_0_ada: Nmax = %ld err = %le\nS2 = %le %le", Nmax, err, real(S2), imag(S2)); - fprintf (stderr, "\nb = %le %le z = %le %le", real(b), imag(b), real(z), imag(z)); -} - -*f_re = real(S2); -*f_im = imag(S2); - -return 0; -} - -/*******************************************************************/ - -int hypergeometric1f1_cont_fract_1_modified_0_ada_ (double *b_re, double *b_im, double *z_re, double *z_im, double *f_re, double *f_im) -{ -//computes modified function 1F1m(a,b,z) for a = 1 and complex b & z by continued fraction -//1F1 = 1 + z/b + z^2/b/(b+1)*(1 + 1F1m) - -complex b(*b_re, *b_im), z(*z_re, *z_im); - -// fortnum computes F11m = 1F1(1;b+2;z) - 1 directly, avoiding the -// cancellation of the |z/b|-dispatch reconstruction at small z. -fortnum_complex result; -fortnum_hyperg_1f1m_a1 (b, z, &result); - -*f_re = result.real(); -*f_im = result.imag(); - -return 0; -} - -/*******************************************************************/ - -int hypergeometric1f1_cont_fract_1_inv_ada_ (double *b_re, double *b_im, double *z_re, double *z_im, double *f_re, double *f_im) -{ -//computes function 1F1(a,b,z) for a = 1 and complex b & z by inverse evaluation of continued fractions -complex b(*b_re-1.0, *b_im), z(*z_re, *z_im); - -complex term, S1, S2; -double err, eps = DBL_EPSILON; -int n, Nmax, maxNmax = 1e6; - -for (Nmax=4; Nmax0; n--) - { - term = ((double)n) * z / (b - z + (double)n + term); - } - - S1 = b / (b - z + term); - - n = Nmax+1; - term = ((double)n) * z / (b - z + (double)n); - for (n=Nmax; n>0; n--) - { - term = ((double)n) * z / (b - z + (double)n + term); - } - - S2 = b / (b - z + term); - - //err = min (abs((S2-S1)/S2), abs(S2-S1)); - err = abs((S2-S1)/S2); - - if (err < eps) break; -} - -//fprintf (stdout, "\nhypergeometric1f1_cont_fract_1_inv_ada: Nmax = %d err = %le\nS2 = %.20le %.20le", Nmax, err, real(S2), imag(S2)); - -if (Nmax >= maxNmax) -{ - fprintf (stderr, "\nwarning: hypergeometric1f1_cont_fract_1_inv_ada: Nmax = %d err = %le\nS2 = %le %le", Nmax, err, real(S2), imag(S2)); - fprintf (stderr, "\nb = %le %le z = %le %le term = %le %le", real(b)+1.0, imag(b), real(z), imag(z), real(term), imag(term)); -} - -*f_re = real(S2); -*f_im = imag(S2); - -return 0; -} - -/*******************************************************************/ - -int hypergeometric1f1_cont_fract_1_inv_nmax_ (double *b_re, double *b_im, double *z_re, double *z_im, double *f_re, double *f_im) -{ -//computes function 1F1(a,b,z) for a = 1 and complex b & z by inverse evaluation of continued fractions -const int Nmax = 1e3; //actually must be calculated from error estimation! - -complex b(*b_re-1.0, *b_im), z(*z_re, *z_im); - -complex term; - -int n = Nmax; - -term = ((double)n) * z / (b - z + (double)n); - -for (n=Nmax-1; n>0; n--) -{ - term = ((double)n) * z / (b - z + (double)n + term); -} - -term = b / (b - z + term); - -*f_re = real(term); -*f_im = imag(term); - -return 0; -} - -/*******************************************************************/ - -int hypergeometric1f1_cont_fract_1_dir_ (double *b_re, double *b_im, double *z_re, double *z_im, double *f_re, double *f_im) -{ -//computes function 1F1(a,b,z) for a = 1 and complex b & z by direct evaluation of continued fractions: warning: this method is UNSTABLE sometimes! -const long int Nmax = 1e6; -const double eps = DBL_EPSILON; -double err; - -complex b(*b_re-1.0, *b_im), z(*z_re, *z_im); - -complex An2, An1, An, Bn2, Bn1, Bn; -complex an, bn; -complex Sn1, Sn; - -An2 = 1.0e0; An1 = 0.0e0; -Bn2 = 0.0e0; Bn1 = 1.0e0; -Sn1 = An1/Bn1; - -long int n; - -for (n=1; n Confluent hypergeometric function 1F1(a,b,z) for a = 1 and complex b, z. +!> +!> Fortran port of the former hyper1F1.cpp. Each routine keeps its single-trailing +!> -underscore C symbol so the existing Fortran callers (KiLCA conductivity, +!> QL-Balance W2_arr) link unchanged. Inputs/outputs are real(c_double) by +!> reference, matching the former extern "C" double* signatures. The quadrature +!> variant defers to fortnum's clean-room 1F1; the others reproduce the Kummer +!> series and continued-fraction evaluations verbatim. +module kilca_hyper1f1_m + use, intrinsic :: iso_c_binding, only: c_double + use, intrinsic :: iso_fortran_env, only: dp => real64, int64, error_unit + implicit none + private + + complex(dp), parameter :: im = (0.0_dp, 1.0_dp) + +contains + + subroutine h_quad(b_re, b_im, z_re, z_im, f_re, f_im) & + bind(C, name="hypergeometric1f1_quad_") + use fortnum_special_hypergeometric_1f1, only: hyperg_1f1_a1 + use fortnum_status, only: fortnum_status_t + real(c_double), intent(in) :: b_re, b_im, z_re, z_im + real(c_double), intent(out) :: f_re, f_im + complex(dp) :: b, z, res + type(fortnum_status_t) :: status + + b = cmplx(b_re, b_im, dp) + z = cmplx(z_re, z_im, dp) + call hyperg_1f1_a1(b, z, res, status) + f_re = real(res, dp) + f_im = aimag(res) + end subroutine h_quad + + subroutine h_kummer_nmax(b_re, b_im, z_re, z_im, f_re, f_im) & + bind(C, name="hypergeometric1f1_kummer_nmax_") + real(c_double), intent(in) :: b_re, b_im, z_re, z_im + real(c_double), intent(out) :: f_re, f_im + complex(dp) :: b, z, term + integer(int64) :: N, n_ + + b = cmplx(b_re, b_im, dp) + z = cmplx(z_re, z_im, dp) + N = int(ceiling(-20.0_dp/log10(abs(z/b))), int64) + 5 + if (N < 1 .or. N > 1000000_int64) call warn_nb(b, z) + + term = z/(b + real(N, dp)) + do n_ = N - 1, 0, -1 + term = 1.0_dp + z/(b + real(n_, dp))*term + end do + + f_re = real(term, dp) + f_im = aimag(term) + end subroutine h_kummer_nmax + + subroutine h_kummer_ada(b_re, b_im, z_re, z_im, f_re, f_im) & + bind(C, name="hypergeometric1f1_kummer_ada_") + real(c_double), intent(in) :: b_re, b_im, z_re, z_im + real(c_double), intent(out) :: f_re, f_im + complex(dp) :: b, z, term, S1, S2 + real(dp) :: err, eps + integer(int64) :: n_, Nmax, maxNmax + + b = cmplx(b_re, b_im, dp) + z = cmplx(z_re, z_im, dp) + eps = epsilon(1.0_dp) + maxNmax = 100000000_int64 + err = 0.0_dp; S2 = (0.0_dp, 0.0_dp) + + Nmax = 4 + do while (Nmax < maxNmax) + term = z/(b + real(Nmax, dp)) + do n_ = Nmax - 1, 0, -1 + term = 1.0_dp + z/(b + real(n_, dp))*term + end do + S1 = term + + term = z/(b + real(Nmax + 1, dp)) + do n_ = Nmax, 0, -1 + term = 1.0_dp + z/(b + real(n_, dp))*term + end do + S2 = term + + err = min(abs((S2 - S1)/S2), abs(S2 - S1)) + if (err < eps) exit + Nmax = Nmax*2 + end do + + if (Nmax >= maxNmax) call warn_conv("kummer_ada", Nmax, err, S2, b, z) + + f_re = real(S2, dp) + f_im = aimag(S2) + end subroutine h_kummer_ada + + subroutine h_kummer_modified_1(b_re, b_im, z_re, z_im, f_re, f_im) & + bind(C, name="hypergeometric1f1_kummer_modified_1_") + real(c_double), intent(in) :: b_re, b_im, z_re, z_im + real(c_double), intent(out) :: f_re, f_im + complex(dp) :: b, z, term + integer(int64) :: N, n_ + + b = cmplx(b_re, b_im, dp) + z = cmplx(z_re, z_im, dp) + N = int(ceiling(-20.0_dp/log10(abs(z/b))), int64) + 5 + if (N < 1 .or. N > 1000000_int64) call warn_nb(b, z) + + term = z/(b + real(N, dp)) + do n_ = N - 1, 2, -1 + term = 1.0_dp + z/(b + real(n_, dp))*term + end do + + f_re = real(term, dp) + f_im = aimag(term) + end subroutine h_kummer_modified_1 + + subroutine h_kummer_modified_0_nmax(b_re, b_im, z_re, z_im, f_re, f_im) & + bind(C, name="hypergeometric1f1_kummer_modified_0_nmax_") + real(c_double), intent(in) :: b_re, b_im, z_re, z_im + real(c_double), intent(out) :: f_re, f_im + complex(dp) :: b, z, term + integer(int64) :: N, n_ + + b = cmplx(b_re, b_im, dp) + z = cmplx(z_re, z_im, dp) + N = int(ceiling(-20.0_dp/log10(abs(z/b))), int64) + 5 + if (N < 1 .or. N > 1000000_int64) call warn_nb(b, z) + + term = z/(b + real(N, dp)) + do n_ = N - 1, 3, -1 + term = 1.0_dp + z/(b + real(n_, dp))*term + end do + term = term*(z/(b + 2.0_dp)) + + f_re = real(term, dp) + f_im = aimag(term) + end subroutine h_kummer_modified_0_nmax + + subroutine h_kummer_modified_0_ada(b_re, b_im, z_re, z_im, f_re, f_im) & + bind(C, name="hypergeometric1f1_kummer_modified_0_ada_") + real(c_double), intent(in) :: b_re, b_im, z_re, z_im + real(c_double), intent(out) :: f_re, f_im + complex(dp) :: b, z, term, S1, S2 + real(dp) :: err, eps + integer(int64) :: n_, Nmax, maxNmax + + b = cmplx(b_re, b_im, dp) + z = cmplx(z_re, z_im, dp) + eps = epsilon(1.0_dp) + maxNmax = 100000000_int64 + err = 0.0_dp; S2 = (0.0_dp, 0.0_dp) + + Nmax = 4 + do while (Nmax < maxNmax) + term = z/(b + real(Nmax, dp)) + do n_ = Nmax - 1, 3, -1 + term = 1.0_dp + (z/(b + real(n_, dp)))*term + end do + S1 = term*(z/(b + 2.0_dp)) + + term = z/(b + real(Nmax + 1, dp)) + do n_ = Nmax, 3, -1 + term = 1.0_dp + (z/(b + real(n_, dp)))*term + end do + S2 = term*(z/(b + 2.0_dp)) + + err = abs((S2 - S1)/S2) + if (err < eps) exit + Nmax = Nmax*2 + end do + + if (Nmax >= maxNmax) call warn_conv("kummer_modified_0_ada", Nmax, err, S2, b, z) + + f_re = real(S2, dp) + f_im = aimag(S2) + end subroutine h_kummer_modified_0_ada + + subroutine h_cont_fract_1_modified_0_ada(b_re, b_im, z_re, z_im, f_re, f_im) & + bind(C, name="hypergeometric1f1_cont_fract_1_modified_0_ada_") + use fortnum_special_hypergeometric_1f1, only: hyperg_1f1m_a1 + use fortnum_status, only: fortnum_status_t + real(c_double), intent(in) :: b_re, b_im, z_re, z_im + real(c_double), intent(out) :: f_re, f_im + complex(dp) :: b, z, res + type(fortnum_status_t) :: status + + b = cmplx(b_re, b_im, dp) + z = cmplx(z_re, z_im, dp) + + ! fortnum computes F11m = 1F1(1;b+2;z) - 1 directly, avoiding the + ! cancellation of the |z/b|-dispatch reconstruction. Mirrors the C++ + ! swap in KAMEL#146 so oracle and port share one compiled kernel. + call hyperg_1f1m_a1(b, z, res, status) + f_re = real(res, dp) + f_im = aimag(res) + end subroutine h_cont_fract_1_modified_0_ada + + subroutine h_cont_fract_1_inv_ada(b_re, b_im, z_re, z_im, f_re, f_im) & + bind(C, name="hypergeometric1f1_cont_fract_1_inv_ada_") + real(c_double), intent(in) :: b_re, b_im, z_re, z_im + real(c_double), intent(out) :: f_re, f_im + complex(dp) :: b, z, term, S1, S2 + real(dp) :: err, eps + integer(int64) :: n_, Nmax, maxNmax + + b = cmplx(b_re - 1.0_dp, b_im, dp) + z = cmplx(z_re, z_im, dp) + eps = epsilon(1.0_dp) + maxNmax = 1000000_int64 + err = 0.0_dp; S2 = (0.0_dp, 0.0_dp) + + Nmax = 4 + do while (Nmax < maxNmax) + term = real(Nmax, dp)*z/(b - z + real(Nmax, dp)) + do n_ = Nmax - 1, 1, -1 + term = real(n_, dp)*z/(b - z + real(n_, dp) + term) + end do + S1 = b/(b - z + term) + + term = real(Nmax + 1, dp)*z/(b - z + real(Nmax + 1, dp)) + do n_ = Nmax, 1, -1 + term = real(n_, dp)*z/(b - z + real(n_, dp) + term) + end do + S2 = b/(b - z + term) + + err = abs((S2 - S1)/S2) + if (err < eps) exit + Nmax = Nmax*2 + end do + + if (Nmax >= maxNmax) call warn_conv("cont_fract_1_inv_ada", Nmax, err, S2, b, z) + + f_re = real(S2, dp) + f_im = aimag(S2) + end subroutine h_cont_fract_1_inv_ada + + subroutine h_cont_fract_1_inv_nmax(b_re, b_im, z_re, z_im, f_re, f_im) & + bind(C, name="hypergeometric1f1_cont_fract_1_inv_nmax_") + real(c_double), intent(in) :: b_re, b_im, z_re, z_im + real(c_double), intent(out) :: f_re, f_im + complex(dp) :: b, z, term + integer(int64), parameter :: Nmax = 1000_int64 + integer(int64) :: n_ + + b = cmplx(b_re - 1.0_dp, b_im, dp) + z = cmplx(z_re, z_im, dp) + + term = real(Nmax, dp)*z/(b - z + real(Nmax, dp)) + do n_ = Nmax - 1, 1, -1 + term = real(n_, dp)*z/(b - z + real(n_, dp) + term) + end do + term = b/(b - z + term) + + f_re = real(term, dp) + f_im = aimag(term) + end subroutine h_cont_fract_1_inv_nmax + + subroutine h_cont_fract_1_dir(b_re, b_im, z_re, z_im, f_re, f_im) & + bind(C, name="hypergeometric1f1_cont_fract_1_dir_") + real(c_double), intent(in) :: b_re, b_im, z_re, z_im + real(c_double), intent(out) :: f_re, f_im + complex(dp) :: b, z, An2, An1, An, Bn2, Bn1, Bn, acoef, bcoef, Sn1, Sn + real(dp) :: err, eps + integer(int64) :: n_, Nmax + + b = cmplx(b_re - 1.0_dp, b_im, dp) + z = cmplx(z_re, z_im, dp) + eps = epsilon(1.0_dp) + Nmax = 1000000_int64 + err = 0.0_dp + + An2 = (1.0_dp, 0.0_dp); An1 = (0.0_dp, 0.0_dp) + Bn2 = (0.0_dp, 0.0_dp); Bn1 = (1.0_dp, 0.0_dp) + Sn1 = An1/Bn1 + An = An1; Bn = Bn1; Sn = Sn1 + + n_ = 1 + do while (n_ < Nmax) + acoef = real(n_, dp)*z + bcoef = b - z + real(n_, dp) + An = bcoef*An1 + acoef*An2 + Bn = bcoef*Bn1 + acoef*Bn2 + Sn = An/Bn + err = min(abs((Sn - Sn1)/Sn), abs(Sn - Sn1)) + if (err < eps) exit + An2 = An1; An1 = An + Bn2 = Bn1; Bn1 = Bn + Sn1 = Sn + n_ = n_ + 1 + end do + + Sn = b/(b - z + Sn) + + if (n_ == Nmax) call warn_conv("cont_fract_1_dir", n_, err, Sn, b, z) + + f_re = real(Sn, dp) + f_im = aimag(Sn) + end subroutine h_cont_fract_1_dir + + subroutine warn_nb(b, z) + complex(dp), intent(in) :: b, z + write (error_unit, '(a)') "warning: hypergeometric1F1_kummer: N out of range" + write (error_unit, '(a,4es12.4)') " b,z=", real(b, dp), aimag(b), real(z, dp), aimag(z) + end subroutine warn_nb + + subroutine warn_conv(tag, Nmax, err, S, b, z) + character(*), intent(in) :: tag + integer(int64), intent(in) :: Nmax + real(dp), intent(in) :: err + complex(dp), intent(in) :: S, b, z + write (error_unit, '(a,a,a,i0,a,es12.4)') & + "warning: hypergeometric1f1_", tag, ": Nmax=", Nmax, " err=", err + write (error_unit, '(a,4es12.4)') " S,b,z(partial)=", & + real(S, dp), aimag(S), real(z, dp), aimag(z) + end subroutine warn_conv + +end module kilca_hyper1f1_m diff --git a/KiLCA/math/lapack.h b/KiLCA/math/lapack.h deleted file mode 100644 index 9399018c..00000000 --- a/KiLCA/math/lapack.h +++ /dev/null @@ -1,39 +0,0 @@ -/*! \file - \brief C declarations of some of LAPACK Fortran subroutines. -*/ - -#if defined(__cplusplus) -extern "C" { -#endif - -/*-----------------------------------------------------------------*/ - -void zgeqrf_ (int *, int *, double *, int *, double *, double *, int *, int *); - -void zungqr_ (int *, int *, int *, double *, int *, double *, double *, int *, int *); - -void zunmqr_ (char *, char *, int *, int *, int *, double *, int *, double *, int *, double *, int *, int *); - -void zgemm_ (char *, char *, int *, int *, int *, double *, double *, int *, double *, int *, double *, double *, int *); - -void ztrtri_ (char *, char *, int *, double *, int *, int *); - -void zgemv_ (char *, int *, int *, double *, double *, int *, double *, int *, double *, double *, int *); - -void ztrmm_ (char *, char *, char *, char *, int *, int *, double *, double *, int *, double *, int *); - -void zgeevr_ (char *, char *, int *, double *, int *, double *, double *, int *, double *, int *, double *, int *, double *, int *); - -void zgetrf_ (int *, int *, double *, int *, int *, int *); - -void zgetri_ (int *, double *, int *, int *, double *, int *, int *); - -void zgesv_ (int *, int *, double *, int *, int *, double *, int *, int *); - -void dgesv_ (int *, int *, double *, int *, int *, double *, int *, int *); - -/*-----------------------------------------------------------------*/ - -#if defined(__cplusplus) -} -#endif diff --git a/KiLCA/mode/calc_mode.cpp b/KiLCA/mode/calc_mode.cpp deleted file mode 100644 index a177ba2e..00000000 --- a/KiLCA/mode/calc_mode.cpp +++ /dev/null @@ -1,943 +0,0 @@ -/*! \file - \brief The implementation of mode_data class and other functions declared in mode.h. -*/ - -#include "fortnum.h" - -#include -#include -#include -#include - -#include "constants.h" -#include "mode.h" -#include "eval_back.h" -#include "zone.h" -#include "stitching.h" -#include "interp.h" -#include "transforms.h" - -#include "hmedium_zone.h" -#include "imhd_zone.h" -#include "flre_zone.h" - -/*****************************************************************************/ - -double qminusq0(double x, void *p) -{ - func_params *P = (func_params *)p; - - return q(x, P->bp) - P->q_res; -} - -/*****************************************************************************/ - -int mode_data::find_resonance_location(void) -{ - double q_res = - ((double)(wd->m)) / ((double)(wd->n)); - - double r1 = bp->x[0], r2 = bp->x[bp->dimx - 1]; - - if ((q(r1, bp) - q_res) * (q(r2, bp) - q_res) > 0) - { - if (DEBUG_FLAG) - { - fprintf(stdout, "\nfind_resonance_location: resonant surface for the mode m=%d n=%d is absent", wd->m, wd->n); - } - wd->r_res = 0.0e0; - return 0; - } - - int max_iter = 100; - - struct func_params params = {bp, q_res}; - - double root = 0.0e0; - int status = fortnum_root_brent(&qminusq0, r1, r2, 0.0e0, 0.0e0, max_iter, - &root, ¶ms); - - if (status != FORTNUM_OK) - { - fprintf(stdout, "\nfind_resonance_location: failed to find resonant surface for the mode m=%d n=%d", wd->m, wd->n); - wd->r_res = 0.0e0; - return 0; - } - - wd->r_res = root; - - if (DEBUG_FLAG) - { - fprintf(stdout, "\nresonant surface for the mode m=%d n=%d is found at:\nr=%.16le, q(r)=%.16le\n", wd->m, wd->n, wd->r_res, q(wd->r_res, bp)); - } - return 1; -} - -/*****************************************************************************/ - -void mode_data::check_zones_parameters(void) -{ - for (int k = 0; k < Nzones - 1; k++) - { - if (zones[k]->r2 != zones[k + 1]->r1 || zones[k]->bc2 != zones[k + 1]->bc1) - { - fprintf(stdout, "\ncheck_zones: boundaries are different: k = %d", k); - exit(1); - } - - if (!(zones[k]->bc2 == BOUNDARY_INTERFACE || zones[k]->bc2 == BOUNDARY_ANTENNA)) - { - fprintf(stdout, "\ncheck_zones: improper type of the right boundary for zone %d: %d", k, zones[k]->bc2); - exit(1); - } - } - - int iz; - - // check that the first boundary is either center or ideal wall: - iz = 0; - if (!(zones[iz]->bc1 == BOUNDARY_CENTER || zones[iz]->bc1 == BOUNDARY_IDEALWALL)) - { - fprintf(stdout, "\ncheck_zones: improper type of the first boundary: %d", zones[iz]->bc1); - exit(1); - } - - // check that the last boundary is either infinity or ideal wall: - iz = Nzones - 1; - if (!(zones[iz]->bc2 == BOUNDARY_INFINITY || zones[iz]->bc2 == BOUNDARY_IDEALWALL)) - { - fprintf(stdout, "\ncheck_zones: improper type of the last boundary: %d", zones[iz]->bc2); - exit(1); - } - - if (DEBUG_FLAG) - { - fprintf(stdout, "\nzones consistency check passed...\n"); - } -} - -/*******************************************************************/ - -void mode_data::allocate_and_setup_zones(void) -{ - Nzones = determine_number_of_zones(sd->path2project); - - if (Nzones < 2) - { - fprintf(stderr, "\nallocate_and_setup_zones: Nzones must be >= 2: %d", Nzones); - exit(1); - } - - zones = new zone *[Nzones]; // array of pointers - - for (int k = 0; k < Nzones; k++) - { - char *filename = get_zone_file_name(sd->path2project, k); - - int type = determine_zone_type(filename); - - if (type > 1 && sd->os->flag_background == 0) - { - fprintf(stderr, "\nerror: allocate_and_setup_zones: background is not set!"); - exit(1); - } - - switch (type) - { - case PLASMA_MODEL_VACUUM: - - zones[k] = new hmedium_zone(sd, bp, (const wave_data *)wd, sd->path2project, k); - zones[k]->read_settings(filename); - break; - - case PLASMA_MODEL_MEDIUM: - - zones[k] = new hmedium_zone(sd, bp, (const wave_data *)wd, sd->path2project, k); - zones[k]->read_settings(filename); - break; - - case PLASMA_MODEL_IMHD: - - zones[k] = new imhd_zone(sd, bp, (const wave_data *)wd, sd->path2project, k); - zones[k]->read_settings(filename); - break; - - case PLASMA_MODEL_RMHD: - - fprintf(stdout, "\nThe plasma model for zone %d is not implemented.", k); - exit(1); - - case PLASMA_MODEL_FLRE: - - zones[k] = new flre_zone(sd, bp, (const wave_data *)wd, sd->path2project, k); - zones[k]->read_settings(filename); - break; - - default: - fprintf(stdout, "\nThe plasma model for zone %d is unknown.", k); - exit(1); - } - - delete[] filename; - } - - check_zones_parameters(); -} - -/*******************************************************************/ - -void mode_data::calc_all_mode_data(int flag) -{ - calc_basis_fields_in_zones(flag); - - if (flag) - return; - - calc_stitching_equations(); - - calc_stitching_equations_determinant(); - - if (sd->os->flag_emfield > 1) - save_mode_det_data(); - - solve_stitching_equations(); - - calc_superposition_of_basis_fields_in_zones(); - - space_out_fields_in_zones(); - - combine_final_wave_fields(); - - setup_wave_fields_for_interpolation(); - - if (sd->os->flag_emfield > 1) - save_final_wave_fields(); - - if (DEBUG_FLAG) - { - calc_and_save_divEB(); - } - - if (sd->os->flag_additional > 0) - { - calc_quants_in_zones(); - - if (sd->os->flag_additional > 1) - save_quants_in_zones(); - - combine_final_quants(); - - if (sd->os->flag_additional > 1) - save_final_quants(); - } -} - -/*******************************************************************/ - -void mode_data::calc_basis_fields_in_zones(int flag) -{ - for (int iz = 0; iz < Nzones; iz++) - { - zones[iz]->calc_basis_fields(flag); - } -} - -/*****************************************************************************/ - -void mode_data::calc_dispersion_in_zones(void) -{ - for (int iz = 0; iz < Nzones; iz++) - { - zones[iz]->calc_dispersion(); - } -} - -/*****************************************************************************/ - -void mode_data::save_dispersion_in_zones(void) -{ - for (int iz = 0; iz < Nzones; iz++) - { - zones[iz]->save_dispersion(); - } -} - -/*****************************************************************************/ - -void mode_data::calc_stitching_equations(void) -{ - Nc = 0; - for (int iz = 0; iz < Nzones; iz++) - { - Nc += zones[iz]->get_dim_of_basis(); - } - - if (DEBUG_FLAG) - { - fprintf(stdout, "\ncalc_stitching_equations: Nc = %d\n", Nc); - } - - A = new double[2 * Nc * 2 * Nc]; // complex system matrix - B = new double[2 * Nc]; // complex system rhs vector - - double *M = new double[2 * Nc * 2 * Nc]; // complex matrix (for each boundary) - double *J = new double[2 * Nc]; // complex rhs vector (for each boundary) - - int neq = 1; // number of equations - int ieq = 0; // equation index - int nvar = 1; // number of variables - int ivar = 0; // variable index - - // set A, B by zeros: - update_system_matrix_and_rhs_vector_(&Nc, A, B, &neq, &ieq, &nvar, &ivar, M, J); - - // initial indices: - ieq = 1; - ivar = 1; - - // first boundary (usually, but not necessary, it is a center): - int iz = 0; - - // dimensions of basis and a basis vector: - int Nw = zones[iz]->get_dim_of_basis(); - int len = zones[iz]->get_dim_of_basis_vector(); - zone *code = zones[iz]; - - // pointers to basis solutions at the boundary: - double *EB = zones[iz]->get_basis_at_left_boundary(); - - if (zones[iz]->medium == PLASMA_MODEL_VACUUM || zones[iz]->medium == PLASMA_MODEL_MEDIUM) - { - switch (zones[iz]->bc1) - { - case BOUNDARY_CENTER: - - center_equations_hommed_(&Nw, &len, (hmedium_zone **)(&code), EB, &neq, &nvar, M, J); - break; - - case BOUNDARY_IDEALWALL: - - ideal_wall_equations_hommed_(&Nw, &len, (hmedium_zone **)(&code), EB, &neq, &nvar, M, J); - break; - - default: - - fprintf(stderr, "\nerror: calc_stitching_equations: first boundary is unknown."); - exit(1); - } - } - else if (zones[iz]->medium == PLASMA_MODEL_IMHD) - { - switch (zones[iz]->bc1) - { - case BOUNDARY_CENTER: - - center_equations_imhd_(&Nw, &len, (imhd_zone **)(&code), EB, &neq, &nvar, M, J); - break; - - case BOUNDARY_IDEALWALL: - - ideal_wall_equations_imhd_(&Nw, &len, (imhd_zone **)(&code), EB, &neq, &nvar, M, J); - break; - - default: - - fprintf(stderr, "\nerror: calc_stitching_equations: first boundary is unknown."); - exit(1); - } - } - else if (zones[iz]->medium == PLASMA_MODEL_RMHD) - { - switch (zones[iz]->bc1) - { - case BOUNDARY_CENTER: - - // center_equations_rmhd_ (&Nw, &len, &code, EB, &neq, &nvar, M, J); - // break; - fprintf(stderr, "\nerror: calc_stitching_equations: not implemented."); - exit(1); - - case BOUNDARY_IDEALWALL: - - // ideal_wall_equations_rmhd_ (&Nw, &len, &code, EB, &neq, &nvar, M, J); - // break; - fprintf(stderr, "\nerror: calc_stitching_equations: not implemented."); - exit(1); - - default: - - fprintf(stderr, "\nerror: calc_stitching_equations: first boundary is unknown."); - exit(1); - } - } - else if (zones[iz]->medium == PLASMA_MODEL_FLRE) - { - switch (zones[iz]->bc1) - { - case BOUNDARY_CENTER: - - center_equations_flre_(&Nw, &len, (flre_zone **)(&code), EB, &neq, &nvar, M, J); - break; - - case BOUNDARY_IDEALWALL: - - ideal_wall_equations_flre_(&Nw, &len, (flre_zone **)(&code), EB, &neq, &nvar, M, J); - break; - - default: - - fprintf(stderr, "\nerror: calc_stitching_equations: first boundary is unknown."); - exit(1); - } - } - else - { - fprintf(stderr, "\nerror: calc_stitching_equations: unknown plasma model."); - exit(1); - } - - // updates equations matrix and rhs vector: - update_system_matrix_and_rhs_vector_(&Nc, A, B, &neq, &ieq, &nvar, &ivar, M, J); - - // updates indices: - ieq += neq; - ivar += 0; // the same zone and variables, so that + 0. - - // fprintf (stdout, "\niz = %d: ieq = %d ivar = %d", iz, ieq, ivar); - - // internal boundaries: - for (iz = 0; iz < Nzones - 1; iz++) - { - int Nw1 = zones[iz + 0]->get_dim_of_basis(); - int Nw2 = zones[iz + 1]->get_dim_of_basis(); - - int len1 = zones[iz + 0]->get_dim_of_basis_vector(); - int len2 = zones[iz + 1]->get_dim_of_basis_vector(); - - zone *code1 = zones[iz + 0]; - zone *code2 = zones[iz + 1]; - - double *EB1 = zones[iz + 0]->get_basis_at_right_boundary(); - double *EB2 = zones[iz + 1]->get_basis_at_left_boundary(); - - int flg_ant; - if (zones[iz]->bc2 == BOUNDARY_ANTENNA) - flg_ant = 1; - else - flg_ant = 0; - - if ((zones[iz + 0]->medium == PLASMA_MODEL_VACUUM || - zones[iz + 0]->medium == PLASMA_MODEL_MEDIUM) && - (zones[iz + 1]->medium == PLASMA_MODEL_VACUUM || - zones[iz + 1]->medium == PLASMA_MODEL_MEDIUM)) - { - stitching_equations_hommed_hommed_(&Nw1, &len1, (hmedium_zone **)(&code1), EB1, - &Nw2, &len2, (hmedium_zone **)(&code2), EB2, - &flg_ant, &neq, &nvar, M, J); - } - else if ((zones[iz + 0]->medium == PLASMA_MODEL_IMHD) && - (zones[iz + 1]->medium == PLASMA_MODEL_VACUUM || - zones[iz + 1]->medium == PLASMA_MODEL_MEDIUM)) - { - stitching_equations_imhd_hommed_(&Nw1, &len1, (imhd_zone **)(&code1), EB1, - &Nw2, &len2, (hmedium_zone **)(&code2), EB2, - &flg_ant, &neq, &nvar, M, J); - } - else if (zones[iz + 0]->medium == PLASMA_MODEL_IMHD && - zones[iz + 1]->medium == PLASMA_MODEL_IMHD) - { - stitching_equations_imhd_imhd_(&Nw1, &len1, (imhd_zone **)(&code1), EB1, - &Nw2, &len2, (imhd_zone **)(&code2), EB2, - &flg_ant, &neq, &nvar, M, J); - } - else if ((zones[iz + 0]->medium == PLASMA_MODEL_RMHD) && - (zones[iz + 1]->medium == PLASMA_MODEL_VACUUM || - zones[iz + 1]->medium == PLASMA_MODEL_MEDIUM)) - { - // stitching_equations_rmhd_hommed_ (&Nw1, &len1, &code1, EB1, &Nw2, &len2, &code2, - // EB2, &flg_ant, &neq, &nvar, M, J); - fprintf(stderr, "\nerror: calc_stitching_equations: not implemented."); - exit(1); - } - else if (zones[iz + 0]->medium == PLASMA_MODEL_RMHD && - zones[iz + 1]->medium == PLASMA_MODEL_RMHD) - { - // stitching_equations_rmhd_rmhd_ (&Nw1, &len1, &code1, EB1, &Nw2, &len2, &code2, - // EB2, &flg_ant, &neq, &nvar, M, J); - fprintf(stderr, "\nerror: calc_stitching_equations: not implemented."); - exit(1); - } - else if ((zones[iz + 0]->medium == PLASMA_MODEL_FLRE) && - (zones[iz + 1]->medium == PLASMA_MODEL_VACUUM || - zones[iz + 1]->medium == PLASMA_MODEL_MEDIUM)) - { - stitching_equations_flre_hommed_(&Nw1, &len1, (flre_zone **)(&code1), EB1, - &Nw2, &len2, (hmedium_zone **)(&code2), EB2, - &flg_ant, &neq, &nvar, M, J); - } - else if (zones[iz + 0]->medium == PLASMA_MODEL_FLRE && - zones[iz + 1]->medium == PLASMA_MODEL_FLRE) - { - stitching_equations_flre_flre_(&Nw1, &len1, (flre_zone **)(&code1), EB1, - &Nw2, &len2, (flre_zone **)(&code2), EB2, - &flg_ant, &neq, &nvar, M, J); - } - else - { - fprintf(stderr, "\nerror: calc_stitching_equations: unknown type of boundary."); - exit(1); - } - - // updates equations matrix and rhs vector: - update_system_matrix_and_rhs_vector_(&Nc, A, B, &neq, &ieq, &nvar, &ivar, M, J); - - // updates indices: - ieq += neq; - ivar += Nw1; - - // fprintf (stdout, "\niz = %d: ieq = %d ivar = %d", iz, ieq, ivar); - } - - // last boundary (usually, but not necessary it is "infinity"): - iz = Nzones - 1; - - // dimensions of basis and a basis vector: - Nw = zones[iz]->get_dim_of_basis(); - len = zones[iz]->get_dim_of_basis_vector(); - code = zones[iz]; - - // pointers to basis solutions at the boundary: - EB = zones[iz]->get_basis_at_right_boundary(); - - if (zones[iz]->medium == PLASMA_MODEL_VACUUM || zones[iz]->medium == PLASMA_MODEL_MEDIUM) - { - switch (zones[iz]->bc2) - { - case BOUNDARY_INFINITY: - - infinity_equations_hommed_(&Nw, &len, (hmedium_zone **)(&code), EB, &neq, &nvar, M, J); - break; - - case BOUNDARY_IDEALWALL: - - ideal_wall_equations_hommed_(&Nw, &len, (hmedium_zone **)(&code), EB, &neq, &nvar, M, J); - break; - - default: - - fprintf(stderr, "\nerror: calc_stitching_equations: last boundary is unknown."); - exit(1); - } - } - else if (zones[iz]->medium == PLASMA_MODEL_IMHD) - { - switch (zones[iz]->bc2) - { - case BOUNDARY_INFINITY: - - infinity_equations_imhd_(&Nw, &len, (imhd_zone **)(&code), EB, &neq, &nvar, M, J); - break; - - case BOUNDARY_IDEALWALL: - - ideal_wall_equations_imhd_(&Nw, &len, (imhd_zone **)(&code), EB, &neq, &nvar, M, J); - break; - - default: - - fprintf(stderr, "\nerror: calc_stitching_equations: last boundary is unknown."); - exit(1); - } - } - else if (zones[iz]->medium == PLASMA_MODEL_RMHD) - { - switch (zones[iz]->bc2) - { - case BOUNDARY_INFINITY: - - // infinity_equations_rmhd_ (&Nw, &len, &code, EB, &neq, &nvar, M, J); - // break; - fprintf(stderr, "\nerror: calc_stitching_equations: not implemented."); - exit(1); - - case BOUNDARY_IDEALWALL: - - // ideal_wall_equations_rmhd_ (&Nw, &len, &code, EB, &neq, &nvar, M, J); - // break; - fprintf(stderr, "\nerror: calc_stitching_equations: not implemented."); - exit(1); - - default: - - fprintf(stderr, "\nerror: calc_stitching_equations: last boundary is unknown."); - exit(1); - } - } - else if (zones[iz]->medium == PLASMA_MODEL_FLRE) - { - switch (zones[iz]->bc2) - { - case BOUNDARY_INFINITY: - - infinity_equations_flre_(&Nw, &len, (flre_zone **)(&code), EB, &neq, &nvar, M, J); - break; - - case BOUNDARY_IDEALWALL: - - ideal_wall_equations_flre_(&Nw, &len, (flre_zone **)(&code), EB, &neq, &nvar, M, J); - break; - - default: - - fprintf(stderr, "\nerror: calc_stitching_equations: last boundary is unknown."); - exit(1); - } - } - else - { - fprintf(stderr, "\nerror: calc_stitching_equations: unknown plasma model."); - exit(1); - } - - // updates equations matrix and rhs vector: - update_system_matrix_and_rhs_vector_(&Nc, A, B, &neq, &ieq, &nvar, &ivar, M, J); - - // updates indices: - ieq += neq; - ivar += Nw; - - // fprintf (stdout, "\niz = %d: ieq = %d ivar = %d", iz, ieq, ivar); - - // check for indices: - if (ieq - 1 != Nc || ivar - 1 != Nc) - { - fprintf(stderr, "\nerror: calc_stitching_equations: wrong final indices: ieq = %d, ivar =%d", ieq, ivar); - exit(1); - } - - // clean up: - delete[] M; - delete[] J; -} - -/*****************************************************************************/ - -void mode_data::calc_stitching_equations_determinant(void) -{ - double det[2]; // fortran complex number - - calc_system_determinant_(&Nc, A, det); - - wd->det = det[0] + I * det[1]; -} - -/*****************************************************************************/ - -void mode_data::solve_stitching_equations(void) -{ - S = new double[2 * Nc]; // complex coefficients (solution) - - find_superposition_coeffs_(&Nc, A, B, S); - - if (DEBUG_FLAG) - { - fprintf(stdout, "\ndeterminat = %.20le %+.20lei\n", real(wd->det), imag(wd->det)); - fprintf(stdout, "\ncheck for superposition coefficients below:"); - for (int i = 0; i < Nc; i++) - { - fprintf(stdout, "\ni = %d: S = %.20le %+.20lei", i, S[2 * i + 0], S[2 * i + 1]); - } - } -} - -/*****************************************************************************/ - -void mode_data::calc_superposition_of_basis_fields_in_zones(void) -{ - int ind = 0; - - for (int iz = 0; iz < Nzones; iz++) - { - zones[iz]->calc_superposition_of_basis_fields(&S[ind]); - - ind += 2 * zones[iz]->get_dim_of_basis(); - } -} - -/*****************************************************************************/ - -void mode_data::space_out_fields_in_zones(void) -{ - for (int iz = 0; iz < Nzones; iz++) - { - zones[iz]->calc_final_fields(); - - if (DEBUG_FLAG) - zones[iz]->save_final_fields(path2linear); - } -} - -/*****************************************************************************/ - -void mode_data::combine_final_wave_fields(void) -{ - dim = 0; - for (int iz = 0; iz < Nzones; iz++) - { - dim += zones[iz]->get_radial_grid_dimension(); - } - - r = new double[dim]; - - EB = new double[dim * 2 * 6]; - - index = new int[Nzones]; - - int ind = 0; - - for (int iz = 0; iz < Nzones; iz++) - { - index[iz] = ind; - - zones[iz]->copy_radial_grid(r + ind); - - zones[iz]->copy_E_and_B_fields(EB + ind * 12); - - ind += zones[iz]->get_radial_grid_dimension(); - } -} - -/*****************************************************************************/ - -void mode_data::setup_wave_fields_for_interpolation(void) -{ - EB_int = new double[dim * 2 * 6]; - - for (int node = 0; node < dim; node++) - { - for (int comp = 0; comp < 6; comp++) - { - for (int part = 0; part < 2; part++) - { - EB_int[iFint(node, comp, part)] = EB[iFFM(node, comp, part)]; - } - } - } -} - -/*****************************************************************************/ - -void mode_data::save_final_wave_fields(void) -{ - char *fname = new char[1024]; - FILE *out = NULL; - - sprintf(fname, "%sEB.dat", path2linear); - - if (!(out = fopen(fname, "w"))) - { - fprintf(stderr, "\nFailed to open file %s\a\n", fname); - } - - for (int i = 0; i < dim; i++) - { - fprintf(out, "%.16le", r[i]); - - for (int comp = 0; comp < 6; comp++) - { - fprintf(out, "\t%.16le\t%.16le", EB[iFFM(i, comp, 0)], EB[iFFM(i, comp, 1)]); - } - fprintf(out, "\n"); - } - - fclose(out); - - delete[] fname; -} - -/*****************************************************************************/ - -void mode_data::calc_quants_in_zones(void) -{ - for (int iz = 0; iz < Nzones; iz++) - { - zones[iz]->calc_all_quants(); - } -} - -/*****************************************************************************/ - -void mode_data::save_quants_in_zones(void) -{ - for (int iz = 0; iz < Nzones; iz++) - { - zones[iz]->save_all_quants(); - } -} - -/*****************************************************************************/ - -void mode_data::combine_final_quants(void) -{ -} - -/*****************************************************************************/ - -void mode_data::save_final_quants(void) -{ -} - -/*****************************************************************************/ - -inline int mode_data::determine_zone_index_for_point(double x) -{ - // determines zone index for the x value: - int ind = -1; - - for (int iz = 0; iz < Nzones; iz++) - { - if (x >= zones[iz]->get_r1() && x <= zones[iz]->get_r2()) - { - ind = iz; - break; - } - } - - if (ind == -1) - { - fprintf(stderr, "\nwarning: determine_zone_index_for_point: x is outside the grid: x = %le", x); - return 0; - } - - return ind; -} - -/*****************************************************************************/ - -void mode_data::divEB(double x, complex *div) -{ - int ind = determine_zone_index_for_point(x); // determines zone index for the x value - - int D = zones[ind]->get_radial_grid_dimension(); - - int deg = 5; // degree of the interpolating polynom - - int i = 0; - - complex EB[6], dEB[6]; - - double *xg = r + index[ind]; // radial grid for the zone - - for (int comp = 0; comp < 6; comp++) - { - double *yg; - - double re[2], im[2]; - - // real part: - yg = &EB_int[iFint(index[ind], comp, 0)]; // EB grid for the zone - - eval_neville_polynom(D, xg, yg, deg, x, 0, 1, &i, re); - - // imag part: - yg = &EB_int[iFint(index[ind], comp, 1)]; // EB grid for the zone - - eval_neville_polynom(D, xg, yg, deg, x, 0, 1, &i, im); - - // set value: - EB[comp] = re[0] + I * im[0]; - dEB[comp] = re[1] + I * im[1]; - } - - double kt = (wd->m) / x, kz = (wd->n) / (sd->bs->rtor); - - div[0] = EB[0] / x + dEB[0] + I * kt * EB[1] + I * kz * EB[2]; - div[1] = EB[3] / x + dEB[3] + I * kt * EB[4] + I * kz * EB[5]; -} - -/*******************************************************************/ - -void mode_data::calc_and_save_divEB(void) -{ - char *fname = new char[1024]; - FILE *out = NULL; - - sprintf(fname, "%sdivEB.dat", path2linear); - - if (!(out = fopen(fname, "w"))) - { - fprintf(stderr, "\nFailed to open file %s\a\n", fname); - } - - delete[] fname; - - complex div[2]; - - for (int i = 0; i < dim; i++) - { - divEB(r[i], div); - - fprintf(out, "%.16le", r[i]); - - fprintf(out, "\t%.16le\t%.16le\t%.16le\t%.16le", real(div[0]), imag(div[0]), - real(div[1]), imag(div[1])); - - fprintf(out, "\n"); - } - - fclose(out); -} - -/*******************************************************************/ - -void mode_data::eval_EB_fields(double x, complex *EB) -{ - int ind = determine_zone_index_for_point(x); // determines zone index for the x value - - int D = zones[ind]->get_radial_grid_dimension(); - - int deg = 5; // degree of the interpolating polynom - - int i = 0; - - double *xg = r + index[ind]; // radial grid for the zone - - for (int comp = 0; comp < 6; comp++) - { - double *yg; - - double re, im; - - // real part: - yg = &EB_int[iFint(index[ind], comp, 0)]; // EB grid for the zone - - eval_neville_polynom(D, xg, yg, deg, x, 0, 0, &i, &re); - - // imag part: - yg = &EB_int[iFint(index[ind], comp, 1)]; // EB grid for the zone - - eval_neville_polynom(D, xg, yg, deg, x, 0, 0, &i, &im); - - // set value: - EB[comp] = re + I * im; - } -} - -/*******************************************************************/ - -void mode_data::eval_diss_power_density(double x, int type, int spec, double *dpd) -{ - int ind = determine_zone_index_for_point(x); // determines zone index for the x value - - zones[ind]->eval_diss_power_density(x, type, spec, dpd); -} - -/*******************************************************************/ - -void mode_data::eval_current_density(double x, int type, int spec, int comp, double *J) -{ - int ind = determine_zone_index_for_point(x); // determines zone index for the x value - - zones[ind]->eval_current_density(x, type, spec, comp, J); -} - -/*******************************************************************/ diff --git a/KiLCA/mode/mode.cpp b/KiLCA/mode/mode.cpp deleted file mode 100644 index c1e2af4e..00000000 --- a/KiLCA/mode/mode.cpp +++ /dev/null @@ -1,210 +0,0 @@ -/*! \file - \brief The implementation of mode_data class. -*/ - -#include -#include -#include - -#include "settings.h" -#include "background.h" -#include "mode.h" -#include "zone.h" - -/*******************************************************************/ - -mode_data::mode_data (int m, int n, complex olab, const settings *sd_p, const background *bp_p) -{ -//set const pointers to common structures: -sd = sd_p; -bp = bp_p; - -set_settings_in_mode_data_module_ (&sd); -set_back_profiles_in_mode_data_module_ (&bp); - -complex omov = olab - n*(sd->bs->V_gal_sys)/(sd->bs->rtor); - -wd = new wave_data (m, n, olab, omov); - -set_wave_data_in_mode_data_module_ (&wd); - -//set_wave_parameters_in_mode_data_module_ (&m, &n, &(real(olab)), &(imag(olab)), -// &(real(omov)), &(imag(omov))); - -double olab_re = real(olab), olab_im = imag(olab); -double omov_re = real(omov), omov_im = imag(omov); - -set_wave_parameters_in_mode_data_module_ (&m, &n, &olab_re, &olab_im, &omov_re, &omov_im); - -if (DEBUG_FLAG) -{ - fprintf (stdout, "\n(m=%d, n=%d): f_lab=(%le, %le) f_mov=(%le, %le)\n", - m, n, real((wd->olab)/2.0/pi), imag((wd->olab)/2.0/pi), - real((wd->omov)/2.0/pi), imag((wd->omov)/2.0/pi)); -} - -if (sd->os->flag_background > 0) -{ - find_resonance_location (); - set_resonance_location_in_mode_data_module_ (&(wd->r_res)); -} - -allocate_and_setup_zones (); - -//Directories for the given mode: -path2linear = new char[1024]; -path2dispersion = new char[1024]; -path2poincare = new char[1024]; - -eval_path_to_linear_data (sd->path2project, m, n, olab, path2linear); - -eval_path_to_dispersion_data (sd->path2project, m, n, olab, path2dispersion); - -eval_path_to_poincare_data (sd->path2project, m, n, olab, path2poincare); - -//makes directories for the mode data: -set_and_make_mode_data_directories (); - -mode_data *tmp = this; -copy_mode_paths_to_mode_data_module_ (&tmp); - -// initialize pointers: -r = 0; -EB = 0; -EB_int = 0; -index = 0; -A = 0; -B = 0; -S = 0; -} - -/*******************************************************************/ - -void eval_path_to_linear_data (const char *path2project, int m, int n, complex olab, char *path2linear) -{ -complex flab = olab/(2.0*pi); - -//linear data directory: -sprintf (path2linear, "%s%s%d%s%d%s%.15lg%s%.15lg%s", path2project, "linear-data/m_", m, "_n_", n, "_flab_[", real(flab), ",", imag(flab), "]/"); -} - -/*******************************************************************/ - -void eval_path_to_dispersion_data (const char *path2project, int m, int n, complex olab, char *path2dispersion) -{ -complex flab = olab/(2.0*pi); - -//dispersion data directory: -sprintf (path2dispersion, "%s%s%d%s%d%s%.15lg%s%.15lg%s", path2project, "dispersion-data/m_", m, "_n_", n, "_flab_[", real(flab), ",", imag(flab), "]/"); -} - -/*******************************************************************/ - -void eval_path_to_poincare_data (const char *path2project, int m, int n, complex olab, char *path2poincare) -{ -complex flab = olab/(2.0*pi); - -//dispersion data directory: -sprintf (path2poincare, "%s%s%d%s%d%s%.15lg%s%.15lg%s", path2project, "poincare-data/m_", m, "_n_", n, "_flab_[", real(flab), ",", imag(flab), "]/"); -} - -/*******************************************************************/ - -void mode_data::set_and_make_mode_data_directories (void) -{ -char *sys_command = new char[1024]; - -if (sd->os->flag_emfield > 1) -{ - sprintf (sys_command, "%s%s", "mkdir -p ", path2linear); - if (system (sys_command)==-1) - { - fprintf (stderr, "\nerror: make_mode_dirs: system()!"); - } - - //makes debug data directory: - sprintf (sys_command, "%s%s%s", "mkdir -p ", path2linear, "debug-data/"); - if (system (sys_command)==-1) - { - fprintf (stderr, "\nerror: make_mode_dirs: system()!"); - } - - //file with the mode data: - FILE *outfile; - - sprintf (sys_command, "%s%s", path2linear, "mode_data.dat"); - - if (!(outfile = fopen (sys_command, "w"))) - { - fprintf (stderr, "\nFailed to open file %s\a\n", sys_command); - } - - fprintf (outfile, "%%m n\n%%Re(flab) Im(flab)\n%%Re(fmov) Im(fmov)\n%%r_res 0.0\n"); - fprintf (outfile, "%d %d\n", wd->m, wd->n); - fprintf (outfile, "%.16lg %.16lg\n", real(wd->olab)/2.0/pi, imag(wd->olab)/2.0/pi); - fprintf (outfile, "%.16lg %.16lg\n", real(wd->omov)/2.0/pi, imag(wd->omov)/2.0/pi); - fprintf (outfile, "%.16lg %.16lg\n", wd->r_res, 0.0); - - fclose (outfile); -} - -if (sd->os->flag_dispersion > 1) -{ - //makes dispersion data directory: - sprintf (sys_command, "%s%s", "mkdir -p ", path2dispersion); - if (system (sys_command)==-1) - { - fprintf (stderr, "\nerror: make_mode_dirs: system()!"); - } -} - -//makes poincare data directory: -//sprintf (sys_command, "%s%s", "mkdir -p ", path2poincare); -//if (system (sys_command)==-1) -//{ -// fprintf (stderr, "\nerror: make_mode_dirs: system()!"); -//} - -delete [] sys_command; -} - -/*****************************************************************************/ - -void copy_mode_paths_from_mode_data_struct_ (mode_data **md, char *path2linear, char *path2dispersion, char *path2poincare) -{ -strcpy (path2linear, (*md)->path2linear); -strcpy (path2dispersion, (*md)->path2dispersion); -strcpy (path2poincare, (*md)->path2poincare); -} - -/*****************************************************************************/ - -void mode_data::save_mode_det_data (void) -{ -char *filename = new char[1024]; -FILE *outfile; - -sprintf (filename, "%smode_%d_%d_[%.16le,%.16le].dat", path2linear, wd->m, wd->n, real(wd->olab), imag(wd->olab)); - -if (!(outfile = fopen (filename, "w"))) -{ - fprintf (stderr, "\nFailed to open file %s\a\n", filename); -} - -fprintf (outfile,"%.16le %.16le\t%.16le %.16le\n", real(wd->olab), imag(wd->olab), real(wd->det), imag(wd->det)); - -fclose (outfile); - -delete [] filename; -} - -/*****************************************************************************/ - -void set_det_in_wd_struct_ (wave_data **wd_ptr, double *re_det, double *im_det) -{ -wave_data *wd = (wave_data *)(*wd_ptr); - -wd->det = (*re_det) + (*im_det)*I; -} - -/*****************************************************************************/ diff --git a/KiLCA/mode/mode.h b/KiLCA/mode/mode.h deleted file mode 100644 index 882c4bec..00000000 --- a/KiLCA/mode/mode.h +++ /dev/null @@ -1,195 +0,0 @@ -/*! \file - \brief The declaration of mode_data class. -*/ - -#ifndef MODE_INCLUDE - -#define MODE_INCLUDE - -#include - -#include "settings.h" -#include "background.h" -#include "wave_data.h" -#include "zone.h" - -/*****************************************************************************/ - -inline int iFFM(int node, int comp, int part) -{ - //indexing function for E, B fields in final EB array in mode class - return part + 2*(comp + 6*node); -} - -/*****************************************************************************/ - -/*! \class mode_data - \brief Class represents data related to a particular mode of a perturbation. -*/ -class mode_data -{ -public: - //pointers to common structures: - const settings *sd; //! olab, const settings *, const background *); - - ~mode_data (void) - { - delete [] path2linear; - delete [] path2dispersion; - delete [] path2poincare; - - delete wd; - - delete [] r; - delete [] EB; - delete [] EB_int; - delete [] index; - - delete [] A; - delete [] B; - delete [] S; - - //loop over zones: - for (int iz=0; iz *divEB); - - void calc_and_save_divEB (void); - - void eval_EB_fields (double, complex *); - - void eval_diss_power_density (double, int type, int spec, double *pdd); - - void eval_current_density (double x, int type, int spec, int comp, double * J); - -private: - int find_resonance_location (void); - - void check_zones_parameters (void); - - void calc_basis_fields_in_zones (int flag = 0); - - void calc_dispersion_in_zones (void); - - void save_dispersion_in_zones (void); - - void calc_stitching_equations (void); - - void calc_stitching_equations_determinant (void); - - void save_mode_det_data (void); - - void solve_stitching_equations (void); - - void calc_superposition_of_basis_fields_in_zones (void); - - void space_out_fields_in_zones (void); - - void combine_final_wave_fields (void); - - void setup_wave_fields_for_interpolation (void); - - void save_final_wave_fields (void); - - void calc_quants_in_zones (void); - - void save_quants_in_zones (void); - - void combine_final_quants (void); - - void save_final_quants (void); -}; - -/*****************************************************************************/ - -struct func_params -{ - const background *bp; - double q_res; -}; - -/*****************************************************************************/ - -double qminusq0 (double x, void *p); - -/*****************************************************************************/ - -void eval_path_to_linear_data (const char *path2project, int m, int n, complex olab, char *path2linear); - -void eval_path_to_dispersion_data (const char *path2project, int m, int n, complex olab, char *path2dispersion); - -void eval_path_to_poincare_data (const char *path2project, int m, int n, complex olab, char *path2poincare); - -/*****************************************************************************/ - -extern "C" -{ -void set_settings_in_mode_data_module_ (const settings **); - -void set_back_profiles_in_mode_data_module_ (const background **); - -void set_wave_data_in_mode_data_module_ (wave_data **); - -void set_wave_parameters_in_mode_data_module_ (int *, int *, double *, double *, double *, double *); - -void set_resonance_location_in_mode_data_module_ (double *r_res); - -void set_current_density_in_antenna_module_ (void); - -void copy_mode_paths_to_mode_data_module_ (mode_data **); - -void copy_mode_paths_from_mode_data_struct_ (mode_data **md, char *path2linear, char *path2dispersion, char *path2poincare); - -void clear_all_data_in_mode_data_module_ (void); - -void set_det_in_wd_struct_ (wave_data **wd_ptr, double *re_det, double *im_det); -} - -/*****************************************************************************/ - -#endif diff --git a/KiLCA/mode/mode_data_m.f90 b/KiLCA/mode/mode_data_m.f90 new file mode 100644 index 00000000..05571607 --- /dev/null +++ b/KiLCA/mode/mode_data_m.f90 @@ -0,0 +1,1284 @@ +!> Per-mode orchestrator, formerly the C++ mode_data class (mode.{h,cpp}) +!> and calc_mode.cpp. Owns one perturbation mode's zone chain, drives basis +!> calculation, builds and solves the stitching-equations linear system at +!> zone boundaries, and combines/interpolates the final lab-frame fields. +!> +!> zones: stored as a plain integer(c_intptr_t) handle array (NOT a +!> class(zone_t) array -- Fortran cannot mix dynamic types in one array, and +!> NOT the private zone_box_t pool type), dispatched via handle_to_zone right +!> before each use, mirroring the oracle's `zone *code = zones[iz]` pattern. +!> +!> EB/EB_int collapse: the oracle kept two differently-laid-out flat arrays, +!> EB (node-major, from iFFM) for storage/output and EB_int (node-minor, from +!> iFint) purely so Neville interpolation could see a node-contiguous y-grid +!> per (component, re/im). A native complex(dp) EB(6,dim) array makes that +!> reshuffle unnecessary: for fixed comp, real(EB(comp,a:b))/aimag(EB(comp, +!> a:b)) is exactly the node-contiguous slice eval_neville_polynom needs +!> (Fortran copies non-contiguous array-valued actual arguments transparently +!> for an INTENT(IN) dummy), so setup_wave_fields_for_interpolation becomes a +!> no-op and is not translated as a separate procedure; its call-sequence +!> point is kept as a comment in mode_data_calc_all_mode_data_. +!> +!> copy_mode_paths_to_mode_data_module_/copy_mode_paths_from_mode_data_struct_: +!> the oracle round-tripped path2linear/path2dispersion/path2poincare into +!> the legacy `mode_data` Fortran module (mode_m.f90) via a C++ method that +!> dereferenced `(mode_data **)this`. With mode_data itself now Fortran there +!> is no such C++ object, so this module writes those three module variables +!> directly (`use mode_data, only: ... => path2linear, ...`) instead of +!> calling the now-impossible round trip; the legacy module ends up holding +!> the exact same strings at the exact same point in construction. +!> +!> Directory scanning (allocate_and_setup_zones' zone_*.in discovery) is +!> translated via direct POSIX opendir/readdir/closedir/fnmatch C interop +!> (glibc x86_64 struct dirent layout, matching this build's platform +!> exactly, same as the oracle's own dirent.h/fnmatch.h includes), preserving +!> readdir's filesystem-order-dependent first-match semantics byte for byte +!> rather than substituting a sorted listing. +module kilca_mode_data_m + use, intrinsic :: iso_c_binding, only: c_int, c_intptr_t, c_double, c_char, & + c_ptr, c_funptr, c_funloc, c_loc, c_f_pointer, c_null_char, c_null_ptr, & + c_associated, c_long, c_short, c_signed_char + use constants, only: dp, twopi + use kilca_zone_m, only: zone_t, handle_to_zone, zone_destroy_c, & + PLASMA_MODEL_VACUUM, PLASMA_MODEL_MEDIUM, PLASMA_MODEL_IMHD, & + PLASMA_MODEL_RMHD, PLASMA_MODEL_FLRE, & + BOUNDARY_CENTER, BOUNDARY_INFINITY, BOUNDARY_IDEALWALL, & + BOUNDARY_INTERFACE, BOUNDARY_ANTENNA, & + Nmed, med_str, skip_line, read_real_before_hash, read_token_before_hash + use kilca_hmedium_zone_m, only: hmedium_zone_create + use kilca_imhd_zone_m, only: imhd_zone_create + use kilca_flre_zone_m, only: flre_zone_create_ + use kilca_wave_data_m, only: wave_data_t, wave_data_create, wave_data_destroy + use kilca_background_data_m, only: get_background_x0, get_background_xlast + use kilca_neville_m, only: eval_neville_polynom + use fortnum_capi, only: fortnum_root_brent + use fortnum_status, only: FORTNUM_OK + use kilca_progs_common_m, only: fmt_g, fmt_e + implicit none + private + + public :: mode_data_t + public :: mode_data_create_, mode_data_destroy_ + public :: mode_data_calc_all_mode_data_ + public :: mode_data_get_wd_, mode_data_get_zone_handle_ + public :: mode_data_eval_EB_fields_, mode_data_eval_diss_power_density_ + public :: mode_data_eval_current_density_ + + type :: mode_data_t + integer(c_intptr_t) :: bp = 1_c_intptr_t + character(len=1024) :: path2project = '' + type(wave_data_t), pointer :: wd => null() + character(len=1024) :: path2linear = '' + character(len=1024) :: path2dispersion = '' + character(len=1024) :: path2poincare = '' + integer :: Nzones = 0 + integer(c_intptr_t), allocatable :: zone_handles(:) + integer :: dim = 0 + real(dp), allocatable :: r(:) + complex(dp), allocatable :: EB(:, :) + integer, allocatable :: index(:) + integer :: Nc = 0 + complex(dp), allocatable :: A(:, :) + complex(dp), allocatable :: B(:) + complex(dp), allocatable :: S(:) + end type mode_data_t + + !> glibc x86_64 struct dirent (default 64-bit ino_t/off_t on LP64 Linux): + !> 8+8+2+1 bytes of header then a NUL-terminated name, no padding before + !> d_name since char has alignment 1. offsetof(d_name) == 19, confirmed + !> against this platform's via offsetof(). + type, bind(c) :: dirent_t + integer(c_long) :: d_ino + integer(c_long) :: d_off + integer(c_short) :: d_reclen + integer(c_signed_char) :: d_type + character(kind=c_char) :: d_name(256) + end type dirent_t + + interface + integer(c_int) function get_output_flag_background() & + bind(C, name="get_output_flag_background_") + import :: c_int + end function get_output_flag_background + + integer(c_int) function get_output_flag_emfield() & + bind(C, name="get_output_flag_emfield_") + import :: c_int + end function get_output_flag_emfield + + integer(c_int) function get_output_flag_additional() & + bind(C, name="get_output_flag_additional_") + import :: c_int + end function get_output_flag_additional + + integer(c_int) function get_output_flag_dispersion() & + bind(C, name="get_output_flag_dispersion_") + import :: c_int + end function get_output_flag_dispersion + + real(c_double) function get_background_rtor() bind(C, name="get_background_rtor_") + import :: c_double + end function get_background_rtor + + real(c_double) function get_background_V_gal_sys() & + bind(C, name="get_background_V_gal_sys_") + import :: c_double + end function get_background_V_gal_sys + + real(c_double) function eval_q_for_resonance(rval, bp) bind(C, name="q") + import :: c_double, c_ptr + real(c_double), value :: rval + type(c_ptr), value :: bp + end function eval_q_for_resonance + + function opendir_c(path) bind(C, name="opendir") result(dirp) + import :: c_char, c_ptr + character(kind=c_char), intent(in) :: path(*) + type(c_ptr) :: dirp + end function opendir_c + + function readdir_c(dirp) bind(C, name="readdir") result(ep) + import :: c_ptr + type(c_ptr), value :: dirp + type(c_ptr) :: ep + end function readdir_c + + integer(c_int) function closedir_c(dirp) bind(C, name="closedir") + import :: c_ptr, c_int + type(c_ptr), value :: dirp + end function closedir_c + + integer(c_int) function fnmatch_c(pattern, str, flags) bind(C, name="fnmatch") + import :: c_char, c_int + character(kind=c_char), intent(in) :: pattern(*), str(*) + integer(c_int), value :: flags + end function fnmatch_c + end interface + + !> Pre-existing bare (non-module) legacy Fortran subroutines: zone + !> boundary-equation builders (hmedium.f90/imhd.f90/flre.f90) and the + !> stitching-system assembly/solve routines (stitching.f90). Called via + !> implicit interface, exactly as their own dummy argument lists declare. + external :: center_equations_hommed, infinity_equations_hommed, & + ideal_wall_equations_hommed, stitching_equations_hommed_hommed + external :: center_equations_imhd, infinity_equations_imhd, & + ideal_wall_equations_imhd, stitching_equations_imhd_hommed, & + stitching_equations_imhd_imhd + external :: center_equations_flre, infinity_equations_flre, & + ideal_wall_equations_flre, stitching_equations_flre_hommed, & + stitching_equations_flre_flre + external :: update_system_matrix_and_rhs_vector, calc_system_determinant, & + find_superposition_coeffs + + !> Pre-existing legacy mode_data module setters (mode_m.f90), bare + !> external subroutines (not module procedures), called natively. + external :: set_settings_in_mode_data_module, set_back_profiles_in_mode_data_module, & + set_wave_data_in_mode_data_module, set_wave_parameters_in_mode_data_module, & + set_resonance_location_in_mode_data_module + +contains + + !> ---- construction / destruction ---- + + function mode_data_create_(m, n, olab_re, olab_im, sd_ptr, bp_ptr, path2project) & + result(handle) bind(C, name="mode_data_create_") + integer(c_int), value :: m, n + real(c_double), value :: olab_re, olab_im + integer(c_intptr_t), value :: sd_ptr, bp_ptr + character(kind=c_char), intent(in) :: path2project(*) + integer(c_intptr_t) :: handle + + type(mode_data_t), pointer :: md + complex(dp) :: olab, omov + integer(c_intptr_t) :: wd_handle + type(c_ptr) :: wd_cptr + real(dp) :: r_res_local + + allocate (md) + md%bp = bp_ptr + md%path2project = c_string_to_fortran_local(path2project) + + call set_settings_in_mode_data_module(sd_ptr) + call set_back_profiles_in_mode_data_module(bp_ptr) + + olab = cmplx(olab_re, olab_im, dp) + omov = olab - real(n, dp)*get_background_V_gal_sys()/get_background_rtor() + + wd_handle = wave_data_create(m, n, olab_re, olab_im, real(omov, dp), aimag(omov)) + wd_cptr = transfer(wd_handle, wd_cptr) + call c_f_pointer(wd_cptr, md%wd) + + call set_wave_data_in_mode_data_module(wd_handle) + + call set_wave_parameters_in_mode_data_module(int(m), int(n), olab_re, olab_im, & + real(omov, dp), aimag(omov)) + + if (get_output_flag_background() > 0) then + call find_resonance_location(md) + r_res_local = md%wd%r_res + call set_resonance_location_in_mode_data_module(r_res_local) + end if + + call allocate_and_setup_zones(md, sd_ptr, bp_ptr, wd_handle) + + call eval_path_to_linear_data(md%path2project, int(m), int(n), olab, md%path2linear) + call eval_path_to_dispersion_data(md%path2project, int(m), int(n), olab, md%path2dispersion) + call eval_path_to_poincare_data(md%path2project, int(m), int(n), olab, md%path2poincare) + + call set_and_make_mode_data_directories(md) + + call copy_mode_paths_to_mode_data_module_native(md) + + handle = mode_data_register(md) + end function mode_data_create_ + + subroutine mode_data_destroy_(handle) bind(C, name="mode_data_destroy_") + integer(c_intptr_t), value :: handle + type(mode_data_t), pointer :: md + integer :: iz + integer(c_intptr_t) :: wdh + + if (handle == 0_c_intptr_t) return + call handle_to_mode_data(handle, md) + + wdh = transfer(c_loc(md%wd), wdh) + call wave_data_destroy(wdh) + + if (allocated(md%r)) deallocate (md%r) + if (allocated(md%EB)) deallocate (md%EB) + if (allocated(md%index)) deallocate (md%index) + if (allocated(md%A)) deallocate (md%A) + if (allocated(md%B)) deallocate (md%B) + if (allocated(md%S)) deallocate (md%S) + + if (allocated(md%zone_handles)) then + do iz = 1, md%Nzones + if (md%zone_handles(iz) /= 0_c_intptr_t) call zone_destroy_c(md%zone_handles(iz)) + end do + deallocate (md%zone_handles) + end if + + deallocate (md) + end subroutine mode_data_destroy_ + + function mode_data_register(md) result(handle) + type(mode_data_t), pointer, intent(in) :: md + integer(c_intptr_t) :: handle + handle = transfer(c_loc(md), handle) + end function mode_data_register + + subroutine handle_to_mode_data(handle, md) + integer(c_intptr_t), value :: handle + type(mode_data_t), pointer, intent(out) :: md + type(c_ptr) :: cp + cp = transfer(handle, cp) + call c_f_pointer(cp, md) + end subroutine handle_to_mode_data + + !> ---- main driver ---- + + subroutine mode_data_calc_all_mode_data_(handle, flag) & + bind(C, name="mode_data_calc_all_mode_data_") + integer(c_intptr_t), value :: handle + integer(c_int), value :: flag + type(mode_data_t), pointer :: md + + call handle_to_mode_data(handle, md) + + call calc_basis_fields_in_zones(md, int(flag)) + + if (flag /= 0) return + + call calc_stitching_equations(md) + + call calc_stitching_equations_determinant(md) + + if (get_output_flag_emfield() > 1) call save_mode_det_data(md) + + call solve_stitching_equations(md) + + call calc_superposition_of_basis_fields_in_zones(md) + + call space_out_fields_in_zones(md) + + call combine_final_wave_fields(md) + + !> setup_wave_fields_for_interpolation: no-op here. The oracle's + !> EB_int (node-minor layout) only existed to give Neville + !> interpolation a node-contiguous y-grid; EB(comp,:) array sections + !> already provide that directly (see module header), so there is + !> nothing left to set up. + + if (get_output_flag_emfield() > 1) call save_final_wave_fields(md) + + !> calc_and_save_divEB: DEBUG_FLAG is hard-coded 0 in code_settings.h + !> (KiLCA/code_settings.h), so this call is dead code in the oracle + !> and is not invoked here either (matches the kilca_flre_zone_m + !> precedent for the same macro). + + if (get_output_flag_additional() > 0) then + call calc_quants_in_zones(md) + + if (get_output_flag_additional() > 1) call save_quants_in_zones(md) + + !> combine_final_quants / save_final_quants are no-ops in the + !> oracle (empty method bodies), so there is nothing to call. + end if + end subroutine mode_data_calc_all_mode_data_ + + !> ---- accessors for still-C++ callers ---- + + function mode_data_get_wd_(handle) result(res) bind(C, name="mode_data_get_wd_") + integer(c_intptr_t), value :: handle + integer(c_intptr_t) :: res + type(mode_data_t), pointer :: md + call handle_to_mode_data(handle, md) + res = transfer(c_loc(md%wd), res) + end function mode_data_get_wd_ + + function mode_data_get_zone_handle_(handle, zone_ind) result(res) & + bind(C, name="mode_data_get_zone_handle_") + integer(c_intptr_t), value :: handle + integer(c_int), value :: zone_ind + integer(c_intptr_t) :: res + type(mode_data_t), pointer :: md + call handle_to_mode_data(handle, md) + res = md%zone_handles(int(zone_ind) + 1) + end function mode_data_get_zone_handle_ + + subroutine mode_data_eval_EB_fields_(handle, x, EB_out) & + bind(C, name="mode_data_eval_EB_fields_") + integer(c_intptr_t), value :: handle + real(c_double), value :: x + real(c_double), intent(out) :: EB_out(*) + type(mode_data_t), pointer :: md + complex(dp) :: EBc(6) + integer :: comp + + call handle_to_mode_data(handle, md) + call eval_EB_fields(md, real(x, dp), EBc) + do comp = 1, 6 + EB_out(2*comp - 1) = real(EBc(comp), dp) + EB_out(2*comp) = aimag(EBc(comp)) + end do + end subroutine mode_data_eval_EB_fields_ + + subroutine mode_data_eval_diss_power_density_(handle, x, ttype, spec, dpd) & + bind(C, name="mode_data_eval_diss_power_density_") + integer(c_intptr_t), value :: handle + real(c_double), value :: x + integer(c_int), value :: ttype, spec + real(c_double), intent(out) :: dpd(*) + type(mode_data_t), pointer :: md + class(zone_t), pointer :: z + integer :: izz + + call handle_to_mode_data(handle, md) + izz = determine_zone_index_for_point(md, real(x, dp)) + call handle_to_zone(md%zone_handles(izz), z) + call z%eval_diss_power_density(real(x, dp), int(ttype), int(spec), dpd) + end subroutine mode_data_eval_diss_power_density_ + + subroutine mode_data_eval_current_density_(handle, x, ttype, spec, comp, J) & + bind(C, name="mode_data_eval_current_density_") + integer(c_intptr_t), value :: handle + real(c_double), value :: x + integer(c_int), value :: ttype, spec, comp + real(c_double), intent(out) :: J(*) + type(mode_data_t), pointer :: md + class(zone_t), pointer :: z + integer :: izz + + call handle_to_mode_data(handle, md) + izz = determine_zone_index_for_point(md, real(x, dp)) + call handle_to_zone(md%zone_handles(izz), z) + call z%eval_current_density(real(x, dp), int(ttype), int(spec), int(comp), J) + end subroutine mode_data_eval_current_density_ + + !> ---- legacy mode_data (mode_m.f90) module bridging ---- + + !> Replaces the oracle's copy_mode_paths_to_mode_data_module_ / + !> copy_mode_paths_from_mode_data_struct_ round trip (the latter + !> dereferenced a C++ `mode_data **`, which no longer exists): the + !> legacy mode_data module's path variables are public, so this writes + !> them directly. Same end state, same point in construction. + subroutine copy_mode_paths_to_mode_data_module_native(md) + use mode_data, only: md_path2linear => path2linear, & + md_path2dispersion => path2dispersion, md_path2poincare => path2poincare + type(mode_data_t), intent(in) :: md + md_path2linear = md%path2linear + md_path2dispersion = md%path2dispersion + md_path2poincare = md%path2poincare + end subroutine copy_mode_paths_to_mode_data_module_native + + !> ---- mode_data::save_mode_det_data (mode.cpp) ---- + + subroutine save_mode_det_data(md) + type(mode_data_t), intent(in) :: md + character(len=1024) :: fname + integer :: unit, ios + + write (fname, '(a,a,i0,a,i0,a,a,a,a,a)') trim(md%path2linear), & + 'mode_', md%wd%m, '_', md%wd%n, '_[', fmt_e(real(md%wd%olab, dp), 16), ',', & + fmt_e(aimag(md%wd%olab), 16), '].dat' + + open (newunit=unit, file=trim(fname), status='replace', action='write', iostat=ios) + if (ios /= 0) then + write (*, '(a,a)') 'Failed to open file ', trim(fname) + end if + + ! Mirrors the oracle's fprintf format exactly: + ! "%.16le %.16le\t%.16le %.16le\n" (two spaces / tab / two spaces). + write (unit, '(a,a,a,a,a,a,a)') & + fmt_e(real(md%wd%olab, dp), 16), ' ', fmt_e(aimag(md%wd%olab), 16), char(9), & + fmt_e(real(md%wd%det, dp), 16), ' ', fmt_e(aimag(md%wd%det), 16) + + close (unit) + end subroutine save_mode_det_data + + !> ---- mode_data::find_resonance_location (calc_mode.cpp) ---- + + subroutine find_resonance_location(md) + type(mode_data_t), intent(inout) :: md + real(dp) :: q_res, r1v, r2v, root + real(dp), target :: q_res_ctx + integer(c_int) :: status + + q_res = -real(md%wd%m, dp)/real(md%wd%n, dp) + r1v = get_background_x0() + r2v = get_background_xlast() + + if ((eval_q_for_resonance(r1v, c_null_ptr) - q_res)* & + (eval_q_for_resonance(r2v, c_null_ptr) - q_res) > 0.0_dp) then + md%wd%r_res = 0.0_dp + return + end if + + q_res_ctx = q_res + status = fortnum_root_brent(c_funloc(qminusq0_cb), r1v, r2v, 0.0_dp, 0.0_dp, & + 100, root, c_loc(q_res_ctx)) + + if (status /= FORTNUM_OK) then + md%wd%r_res = 0.0_dp + return + end if + + md%wd%r_res = root + end subroutine find_resonance_location + + !> q(x) - q_res, the resonance-location root-finding callback. The + !> background* parameter of the oracle's q() is unused by eval_q + !> (background_data_m.f90), so c_null_ptr is passed for it, matching the + !> sentinel-bp precedent already established for zone_t. + function qminusq0_cb(x, ctx) result(y) bind(C) + real(c_double), value :: x + type(c_ptr), value :: ctx + real(c_double) :: y + real(dp), pointer :: q_res_p + call c_f_pointer(ctx, q_res_p) + y = eval_q_for_resonance(x, c_null_ptr) - q_res_p + end function qminusq0_cb + + !> ---- path-string helpers (mode.cpp free functions) ---- + + subroutine eval_path_to_linear_data(path2project, m, n, olab, path2linear) + character(len=*), intent(in) :: path2project + integer, intent(in) :: m, n + complex(dp), intent(in) :: olab + character(len=*), intent(out) :: path2linear + complex(dp) :: flab + flab = olab/twopi + write (path2linear, '(a,a,i0,a,i0,a,a,a,a,a)') trim(path2project), & + 'linear-data/m_', m, '_n_', n, '_flab_[', fmt_g(real(flab, dp), 15), ',', & + fmt_g(aimag(flab), 15), ']/' + end subroutine eval_path_to_linear_data + + subroutine eval_path_to_dispersion_data(path2project, m, n, olab, path2dispersion) + character(len=*), intent(in) :: path2project + integer, intent(in) :: m, n + complex(dp), intent(in) :: olab + character(len=*), intent(out) :: path2dispersion + complex(dp) :: flab + flab = olab/twopi + write (path2dispersion, '(a,a,i0,a,i0,a,a,a,a,a)') trim(path2project), & + 'dispersion-data/m_', m, '_n_', n, '_flab_[', fmt_g(real(flab, dp), 15), ',', & + fmt_g(aimag(flab), 15), ']/' + end subroutine eval_path_to_dispersion_data + + subroutine eval_path_to_poincare_data(path2project, m, n, olab, path2poincare) + character(len=*), intent(in) :: path2project + integer, intent(in) :: m, n + complex(dp), intent(in) :: olab + character(len=*), intent(out) :: path2poincare + complex(dp) :: flab + flab = olab/twopi + write (path2poincare, '(a,a,i0,a,i0,a,a,a,a,a)') trim(path2project), & + 'poincare-data/m_', m, '_n_', n, '_flab_[', fmt_g(real(flab, dp), 15), ',', & + fmt_g(aimag(flab), 15), ']/' + end subroutine eval_path_to_poincare_data + + !> ---- mode_data::set_and_make_mode_data_directories (mode.cpp) ---- + + subroutine set_and_make_mode_data_directories(md) + type(mode_data_t), intent(in) :: md + character(len=1024) :: sys_command, fname + integer :: unit, ierr_unused + + if (get_output_flag_emfield() > 1) then + sys_command = 'mkdir -p '//trim(md%path2linear) + call execute_command_line(trim(sys_command), exitstat=ierr_unused) + + sys_command = 'mkdir -p '//trim(md%path2linear)//'debug-data/' + call execute_command_line(trim(sys_command), exitstat=ierr_unused) + + fname = trim(md%path2linear)//'mode_data.dat' + open (newunit=unit, file=trim(fname), status='replace', action='write') + write (unit, '(a)') '%m n' + write (unit, '(a)') '%Re(flab) Im(flab)' + write (unit, '(a)') '%Re(fmov) Im(fmov)' + write (unit, '(a)') '%r_res 0.0' + write (unit, '(i0,1x,i0)') md%wd%m, md%wd%n + write (unit, '(a,a,a)') fmt_g(real(md%wd%olab, dp)/twopi, 16), ' ', & + fmt_g(aimag(md%wd%olab)/twopi, 16) + write (unit, '(a,a,a)') fmt_g(real(md%wd%omov, dp)/twopi, 16), ' ', & + fmt_g(aimag(md%wd%omov)/twopi, 16) + write (unit, '(a,a,a)') fmt_g(md%wd%r_res, 16), ' ', fmt_g(0.0_dp, 16) + close (unit) + end if + + if (get_output_flag_dispersion() > 1) then + sys_command = 'mkdir -p '//trim(md%path2dispersion) + call execute_command_line(trim(sys_command), exitstat=ierr_unused) + end if + end subroutine set_and_make_mode_data_directories + + !> ---- mode_data::allocate_and_setup_zones (calc_mode.cpp) ---- + + subroutine allocate_and_setup_zones(md, sd_ptr, bp_ptr, wd_handle) + type(mode_data_t), intent(inout) :: md + integer(c_intptr_t), intent(in) :: sd_ptr, bp_ptr, wd_handle + integer :: k, ztype + character(len=1024) :: filename + character(kind=c_char), allocatable :: cpath(:) + class(zone_t), pointer :: z + + md%Nzones = determine_number_of_zones(md%path2project) + + if (md%Nzones < 2) then + write (*, '(a,i0)') 'allocate_and_setup_zones: Nzones must be >= 2: ', md%Nzones + stop 1 + end if + + if (allocated(md%zone_handles)) deallocate (md%zone_handles) + allocate (md%zone_handles(md%Nzones)) + + cpath = to_cstr(md%path2project) + + do k = 0, md%Nzones - 1 + filename = get_zone_file_name(md%path2project, k) + ztype = determine_zone_type(filename) + + if (ztype > 1 .and. get_output_flag_background() == 0) then + write (*, '(a)') 'error: allocate_and_setup_zones: background is not set!' + stop 1 + end if + + select case (ztype) + case (PLASMA_MODEL_VACUUM, PLASMA_MODEL_MEDIUM) + md%zone_handles(k + 1) = hmedium_zone_create(sd_ptr, bp_ptr, wd_handle, & + cpath, int(k, c_int)) + case (PLASMA_MODEL_IMHD) + md%zone_handles(k + 1) = imhd_zone_create(sd_ptr, bp_ptr, wd_handle, & + cpath, int(k, c_int)) + case (PLASMA_MODEL_RMHD) + write (*, '(a,i0,a)') 'The plasma model for zone ', k, ' is not implemented.' + stop 1 + case (PLASMA_MODEL_FLRE) + md%zone_handles(k + 1) = flre_zone_create_(sd_ptr, bp_ptr, wd_handle, & + cpath, int(k, c_int)) + case default + write (*, '(a,i0,a)') 'The plasma model for zone ', k, ' is unknown.' + stop 1 + end select + + call handle_to_zone(md%zone_handles(k + 1), z) + call z%read_settings(trim(filename)) + end do + + call check_zones_parameters(md) + end subroutine allocate_and_setup_zones + + subroutine check_zones_parameters(md) + type(mode_data_t), intent(in) :: md + integer :: k, iz + class(zone_t), pointer :: z1, z2, zends + + do k = 1, md%Nzones - 1 + call handle_to_zone(md%zone_handles(k), z1) + call handle_to_zone(md%zone_handles(k + 1), z2) + + if (z1%get_r2() /= z2%get_r1() .or. z1%bc2 /= z2%bc1) then + write (*, '(a,i0)') 'check_zones: boundaries are different: k = ', k - 1 + stop 1 + end if + + if (.not. (z1%bc2 == BOUNDARY_INTERFACE .or. z1%bc2 == BOUNDARY_ANTENNA)) then + write (*, '(a,i0,a,i0)') & + 'check_zones: improper type of the right boundary for zone ', k - 1, & + ': ', z1%bc2 + stop 1 + end if + end do + + iz = 1 + call handle_to_zone(md%zone_handles(iz), zends) + if (.not. (zends%bc1 == BOUNDARY_CENTER .or. zends%bc1 == BOUNDARY_IDEALWALL)) then + write (*, '(a,i0)') 'check_zones: improper type of the first boundary: ', zends%bc1 + stop 1 + end if + + iz = md%Nzones + call handle_to_zone(md%zone_handles(iz), zends) + if (.not. (zends%bc2 == BOUNDARY_INFINITY .or. zends%bc2 == BOUNDARY_IDEALWALL)) then + write (*, '(a,i0)') 'check_zones: improper type of the last boundary: ', zends%bc2 + stop 1 + end if + end subroutine check_zones_parameters + + !> ---- zone settings-file discovery (calc_mode.cpp statics) ---- + + function determine_number_of_zones(path2project) result(nz) + character(len=*), intent(in) :: path2project + integer :: nz + character(kind=c_char), allocatable :: cpath(:), cpattern(:) + type(c_ptr) :: dirp, ep_cptr + type(dirent_t), pointer :: ep + integer(c_int) :: ret + + cpath = to_cstr(path2project) + cpattern = to_cstr('zone_*.in') + nz = 0 + + dirp = opendir_c(cpath) + if (.not. c_associated(dirp)) then + write (*, '(a,a)') & + 'determine_number_of_zones: faled to open the project directory ', & + trim(path2project) + stop 1 + end if + + do + ep_cptr = readdir_c(dirp) + if (.not. c_associated(ep_cptr)) exit + call c_f_pointer(ep_cptr, ep) + if (fnmatch_c(cpattern, ep%d_name, 0_c_int) == 0) nz = nz + 1 + end do + + ret = closedir_c(dirp) + end function determine_number_of_zones + + function get_zone_file_name(path2project, zone_index) result(fname) + character(len=*), intent(in) :: path2project + integer, intent(in) :: zone_index + character(len=1024) :: fname + character(kind=c_char), allocatable :: cpath(:), cpattern(:) + character(len=32) :: pattern_str + character(len=256) :: dname + type(c_ptr) :: dirp, ep_cptr + type(dirent_t), pointer :: ep + integer :: found + integer(c_int) :: ret + + cpath = to_cstr(path2project) + write (pattern_str, '(a,i0,a)') '*zone_', zone_index + 1, '*.in' + cpattern = to_cstr(trim(pattern_str)) + + fname = '' + found = 0 + + dirp = opendir_c(cpath) + if (.not. c_associated(dirp)) then + write (*, '(a,a)') 'get_zone_file_name: faled to open the project directory ', & + trim(path2project) + stop 1 + end if + + do + ep_cptr = readdir_c(dirp) + if (.not. c_associated(ep_cptr)) exit + call c_f_pointer(ep_cptr, ep) + if (fnmatch_c(cpattern, ep%d_name, 0_c_int) == 0) then + call dirent_name_to_fortran(ep%d_name, dname) + fname = trim(path2project)//trim(dname) + found = 1 + exit + end if + end do + + ret = closedir_c(dirp) + + if (found == 0) then + write (*, '(a,i0,a)') & + 'get_zone_file_name: failed to find the file name for zone ', zone_index, '!' + stop 1 + end if + end function get_zone_file_name + + function determine_zone_type(file) result(medium) + character(len=*), intent(in) :: file + integer :: medium + integer :: unit, ios, k + real(dp) :: dummy_r1 + character(len=64) :: bstr1, mstr + + open (newunit=unit, file=trim(file), status='old', action='read', iostat=ios) + if (ios /= 0) then + write (*, '(a,a)') 'error: determine_zone_type: failed to open file ', trim(file) + stop 0 + end if + + call skip_line(unit) + call read_real_before_hash(unit, dummy_r1) + call read_token_before_hash(unit, bstr1) + call read_token_before_hash(unit, mstr) + + close (unit) + + medium = -1 + do k = 0, Nmed - 1 + if (trim(mstr) == trim(med_str(k))) then + medium = k + exit + end if + end do + + if (medium == -1) then + write (*, '(a,a)') 'error: determine_zone_type: medium type is unknown: ', trim(mstr) + stop 1 + end if + end function determine_zone_type + + subroutine dirent_name_to_fortran(cname, fname) + character(kind=c_char), intent(in) :: cname(:) + character(len=*), intent(out) :: fname + integer :: i + fname = '' + do i = 1, min(size(cname), len(fname)) + if (cname(i) == c_null_char) exit + fname(i:i) = cname(i) + end do + end subroutine dirent_name_to_fortran + + function to_cstr(s) result(c) + character(len=*), intent(in) :: s + character(kind=c_char), allocatable :: c(:) + integer :: i, n + n = len_trim(s) + allocate (c(n + 1)) + do i = 1, n + c(i) = s(i:i) + end do + c(n + 1) = c_null_char + end function to_cstr + + function c_string_to_fortran_local(cstr) result(fstr) + character(kind=c_char), intent(in) :: cstr(*) + character(len=1024) :: fstr + integer :: i + fstr = '' + do i = 1, 1024 + if (cstr(i) == c_null_char) exit + fstr(i:i) = cstr(i) + end do + end function c_string_to_fortran_local + + !> ---- mode_data::calc_basis_fields_in_zones (calc_mode.cpp) ---- + + subroutine calc_basis_fields_in_zones(md, flag) + type(mode_data_t), intent(inout) :: md + integer, intent(in) :: flag + integer :: iz + class(zone_t), pointer :: z + do iz = 1, md%Nzones + call handle_to_zone(md%zone_handles(iz), z) + call z%calc_basis_fields(flag) + end do + end subroutine calc_basis_fields_in_zones + + !> ---- mode_data::calc_stitching_equations (calc_mode.cpp) ---- + + subroutine calc_stitching_equations(md) + type(mode_data_t), intent(inout) :: md + integer :: iz, neq, ieq, nvar, ivar, Nw, len_b, Nw1, Nw2, len1, len2, flg_ant + class(zone_t), pointer :: z, z1, z2 + complex(dp), allocatable :: M(:, :), J(:) + + md%Nc = 0 + do iz = 1, md%Nzones + call handle_to_zone(md%zone_handles(iz), z) + md%Nc = md%Nc + z%get_dim_of_basis() + end do + + if (allocated(md%A)) deallocate (md%A) + allocate (md%A(md%Nc, md%Nc)) + if (allocated(md%B)) deallocate (md%B) + allocate (md%B(md%Nc)) + + allocate (M(md%Nc, md%Nc)) + allocate (J(md%Nc)) + + neq = 1; ieq = 0; nvar = 1; ivar = 0 + + ! zeroes A, B (the legacy routine's ieq == 0 branch is the zeroing call) + call update_system_matrix_and_rhs_vector(md%Nc, md%A, md%B, neq, ieq, nvar, ivar, M, J) + + ieq = 1 + ivar = 1 + + ! first boundary (usually, but not necessarily, a center) + iz = 1 + call handle_to_zone(md%zone_handles(iz), z) + Nw = z%get_dim_of_basis() + len_b = z%get_dim_of_basis_vector() + + if (z%medium == PLASMA_MODEL_VACUUM .or. z%medium == PLASMA_MODEL_MEDIUM) then + select case (z%bc1) + case (BOUNDARY_CENTER) + call center_equations_hommed(Nw, len_b, md%zone_handles(iz), z%basis(:, :, 1), & + neq, nvar, M, J) + case (BOUNDARY_IDEALWALL) + call ideal_wall_equations_hommed(Nw, len_b, md%zone_handles(iz), & + z%basis(:, :, 1), neq, nvar, M, J) + case default + write (*, '(a)') 'error: calc_stitching_equations: first boundary is unknown.' + stop 1 + end select + else if (z%medium == PLASMA_MODEL_IMHD) then + select case (z%bc1) + case (BOUNDARY_CENTER) + call center_equations_imhd(Nw, len_b, md%zone_handles(iz), z%basis(:, :, 1), & + neq, nvar, M, J) + case (BOUNDARY_IDEALWALL) + call ideal_wall_equations_imhd(Nw, len_b, md%zone_handles(iz), & + z%basis(:, :, 1), neq, nvar, M, J) + case default + write (*, '(a)') 'error: calc_stitching_equations: first boundary is unknown.' + stop 1 + end select + else if (z%medium == PLASMA_MODEL_RMHD) then + write (*, '(a)') 'error: calc_stitching_equations: not implemented.' + stop 1 + else if (z%medium == PLASMA_MODEL_FLRE) then + select case (z%bc1) + case (BOUNDARY_CENTER) + call center_equations_flre(Nw, len_b, md%zone_handles(iz), z%basis(:, :, 1), & + neq, nvar, M, J) + case (BOUNDARY_IDEALWALL) + call ideal_wall_equations_flre(Nw, len_b, md%zone_handles(iz), & + z%basis(:, :, 1), neq, nvar, M, J) + case default + write (*, '(a)') 'error: calc_stitching_equations: first boundary is unknown.' + stop 1 + end select + else + write (*, '(a)') 'error: calc_stitching_equations: unknown plasma model.' + stop 1 + end if + + call update_system_matrix_and_rhs_vector(md%Nc, md%A, md%B, neq, ieq, nvar, ivar, M, J) + + ieq = ieq + neq + ! ivar unchanged: same zone & variables (oracle's `ivar += 0`) + + ! internal boundaries + do iz = 1, md%Nzones - 1 + call handle_to_zone(md%zone_handles(iz), z1) + call handle_to_zone(md%zone_handles(iz + 1), z2) + + Nw1 = z1%get_dim_of_basis() + Nw2 = z2%get_dim_of_basis() + len1 = z1%get_dim_of_basis_vector() + len2 = z2%get_dim_of_basis_vector() + + if (z1%bc2 == BOUNDARY_ANTENNA) then + flg_ant = 1 + else + flg_ant = 0 + end if + + if ((z1%medium == PLASMA_MODEL_VACUUM .or. z1%medium == PLASMA_MODEL_MEDIUM) .and. & + (z2%medium == PLASMA_MODEL_VACUUM .or. z2%medium == PLASMA_MODEL_MEDIUM)) then + call stitching_equations_hommed_hommed(Nw1, len1, md%zone_handles(iz), & + z1%basis(:, :, z1%dim), Nw2, len2, md%zone_handles(iz + 1), & + z2%basis(:, :, 1), flg_ant, neq, nvar, M, J) + else if (z1%medium == PLASMA_MODEL_IMHD .and. & + (z2%medium == PLASMA_MODEL_VACUUM .or. z2%medium == PLASMA_MODEL_MEDIUM)) then + call stitching_equations_imhd_hommed(Nw1, len1, md%zone_handles(iz), & + z1%basis(:, :, z1%dim), Nw2, len2, md%zone_handles(iz + 1), & + z2%basis(:, :, 1), flg_ant, neq, nvar, M, J) + else if (z1%medium == PLASMA_MODEL_IMHD .and. z2%medium == PLASMA_MODEL_IMHD) then + call stitching_equations_imhd_imhd(Nw1, len1, md%zone_handles(iz), & + z1%basis(:, :, z1%dim), Nw2, len2, md%zone_handles(iz + 1), & + z2%basis(:, :, 1), flg_ant, neq, nvar, M, J) + else if (z1%medium == PLASMA_MODEL_RMHD .and. & + (z2%medium == PLASMA_MODEL_VACUUM .or. z2%medium == PLASMA_MODEL_MEDIUM)) then + write (*, '(a)') 'error: calc_stitching_equations: not implemented.' + stop 1 + else if (z1%medium == PLASMA_MODEL_RMHD .and. z2%medium == PLASMA_MODEL_RMHD) then + write (*, '(a)') 'error: calc_stitching_equations: not implemented.' + stop 1 + else if (z1%medium == PLASMA_MODEL_FLRE .and. & + (z2%medium == PLASMA_MODEL_VACUUM .or. z2%medium == PLASMA_MODEL_MEDIUM)) then + call stitching_equations_flre_hommed(Nw1, len1, md%zone_handles(iz), & + z1%basis(:, :, z1%dim), Nw2, len2, md%zone_handles(iz + 1), & + z2%basis(:, :, 1), flg_ant, neq, nvar, M, J) + else if (z1%medium == PLASMA_MODEL_FLRE .and. z2%medium == PLASMA_MODEL_FLRE) then + call stitching_equations_flre_flre(Nw1, len1, md%zone_handles(iz), & + z1%basis(:, :, z1%dim), Nw2, len2, md%zone_handles(iz + 1), & + z2%basis(:, :, 1), flg_ant, neq, nvar, M, J) + else + write (*, '(a)') 'error: calc_stitching_equations: unknown type of boundary.' + stop 1 + end if + + call update_system_matrix_and_rhs_vector(md%Nc, md%A, md%B, neq, ieq, nvar, ivar, M, J) + + ieq = ieq + neq + ivar = ivar + Nw1 + end do + + ! last boundary (usually, but not necessarily, infinity) + iz = md%Nzones + call handle_to_zone(md%zone_handles(iz), z) + Nw = z%get_dim_of_basis() + len_b = z%get_dim_of_basis_vector() + + if (z%medium == PLASMA_MODEL_VACUUM .or. z%medium == PLASMA_MODEL_MEDIUM) then + select case (z%bc2) + case (BOUNDARY_INFINITY) + call infinity_equations_hommed(Nw, len_b, md%zone_handles(iz), & + z%basis(:, :, z%dim), neq, nvar, M, J) + case (BOUNDARY_IDEALWALL) + call ideal_wall_equations_hommed(Nw, len_b, md%zone_handles(iz), & + z%basis(:, :, z%dim), neq, nvar, M, J) + case default + write (*, '(a)') 'error: calc_stitching_equations: last boundary is unknown.' + stop 1 + end select + else if (z%medium == PLASMA_MODEL_IMHD) then + select case (z%bc2) + case (BOUNDARY_INFINITY) + call infinity_equations_imhd(Nw, len_b, md%zone_handles(iz), & + z%basis(:, :, z%dim), neq, nvar, M, J) + case (BOUNDARY_IDEALWALL) + call ideal_wall_equations_imhd(Nw, len_b, md%zone_handles(iz), & + z%basis(:, :, z%dim), neq, nvar, M, J) + case default + write (*, '(a)') 'error: calc_stitching_equations: last boundary is unknown.' + stop 1 + end select + else if (z%medium == PLASMA_MODEL_RMHD) then + write (*, '(a)') 'error: calc_stitching_equations: not implemented.' + stop 1 + else if (z%medium == PLASMA_MODEL_FLRE) then + select case (z%bc2) + case (BOUNDARY_INFINITY) + call infinity_equations_flre(Nw, len_b, md%zone_handles(iz), & + z%basis(:, :, z%dim), neq, nvar, M, J) + case (BOUNDARY_IDEALWALL) + call ideal_wall_equations_flre(Nw, len_b, md%zone_handles(iz), & + z%basis(:, :, z%dim), neq, nvar, M, J) + case default + write (*, '(a)') 'error: calc_stitching_equations: last boundary is unknown.' + stop 1 + end select + else + write (*, '(a)') 'error: calc_stitching_equations: unknown plasma model.' + stop 1 + end if + + call update_system_matrix_and_rhs_vector(md%Nc, md%A, md%B, neq, ieq, nvar, ivar, M, J) + + ieq = ieq + neq + ivar = ivar + Nw + + if (ieq - 1 /= md%Nc .or. ivar - 1 /= md%Nc) then + write (*, '(a,i0,a,i0)') & + 'error: calc_stitching_equations: wrong final indices: ieq = ', ieq, & + ', ivar =', ivar + stop 1 + end if + + deallocate (M, J) + end subroutine calc_stitching_equations + + subroutine calc_stitching_equations_determinant(md) + type(mode_data_t), intent(inout) :: md + complex(dp) :: det + call calc_system_determinant(md%Nc, md%A, det) + md%wd%det = det + end subroutine calc_stitching_equations_determinant + + subroutine solve_stitching_equations(md) + type(mode_data_t), intent(inout) :: md + if (allocated(md%S)) deallocate (md%S) + allocate (md%S(md%Nc)) + call find_superposition_coeffs(md%Nc, md%A, md%B, md%S) + end subroutine solve_stitching_equations + + subroutine calc_superposition_of_basis_fields_in_zones(md) + type(mode_data_t), intent(inout) :: md + integer :: iz, ind, nw, i + class(zone_t), pointer :: z + real(dp), allocatable :: S_p(:) + + ind = 0 + do iz = 1, md%Nzones + call handle_to_zone(md%zone_handles(iz), z) + nw = z%get_dim_of_basis() + allocate (S_p(2*nw)) + do i = 1, nw + S_p(2*i - 1) = real(md%S(ind + i), dp) + S_p(2*i) = aimag(md%S(ind + i)) + end do + call z%calc_superposition_of_basis_fields(S_p) + deallocate (S_p) + ind = ind + nw + end do + end subroutine calc_superposition_of_basis_fields_in_zones + + subroutine space_out_fields_in_zones(md) + type(mode_data_t), intent(inout) :: md + integer :: iz + class(zone_t), pointer :: z + do iz = 1, md%Nzones + call handle_to_zone(md%zone_handles(iz), z) + call z%calc_final_fields() + !> zone_save_final_fields_ here is gated behind DEBUG_FLAG, hard + !> -coded 0 (KiLCA/code_settings.h); dead in the oracle, omitted. + end do + end subroutine space_out_fields_in_zones + + subroutine combine_final_wave_fields(md) + type(mode_data_t), intent(inout) :: md + integer :: iz, ind, zdim, node, comp + class(zone_t), pointer :: z + real(dp), allocatable :: ebflat(:) + + md%dim = 0 + do iz = 1, md%Nzones + call handle_to_zone(md%zone_handles(iz), z) + md%dim = md%dim + z%get_radial_grid_dimension() + end do + + if (allocated(md%r)) deallocate (md%r) + allocate (md%r(md%dim)) + if (allocated(md%EB)) deallocate (md%EB) + allocate (md%EB(6, md%dim)) + if (allocated(md%index)) deallocate (md%index) + allocate (md%index(md%Nzones)) + + ind = 0 + do iz = 1, md%Nzones + call handle_to_zone(md%zone_handles(iz), z) + md%index(iz) = ind + zdim = z%get_radial_grid_dimension() + + call z%copy_radial_grid(md%r(ind + 1:ind + zdim)) + + allocate (ebflat(12*zdim)) + call z%copy_E_and_B_fields(ebflat) + do node = 0, zdim - 1 + do comp = 0, 5 + md%EB(comp + 1, ind + node + 1) = cmplx(ebflat(2*(comp + 6*node) + 1), & + ebflat(2*(comp + 6*node) + 2), dp) + end do + end do + deallocate (ebflat) + + ind = ind + zdim + end do + end subroutine combine_final_wave_fields + + subroutine save_final_wave_fields(md) + type(mode_data_t), intent(in) :: md + character(len=1024) :: fname + integer :: unit, i, comp + + fname = trim(md%path2linear)//'EB.dat' + open (newunit=unit, file=trim(fname), status='replace', action='write') + + do i = 1, md%dim + write (unit, '(es24.16e3)', advance='no') md%r(i) + do comp = 1, 6 + write (unit, '(a,es24.16e3,a,es24.16e3)', advance='no') & + char(9), real(md%EB(comp, i), dp), char(9), aimag(md%EB(comp, i)) + end do + write (unit, *) + end do + + close (unit) + end subroutine save_final_wave_fields + + subroutine calc_quants_in_zones(md) + type(mode_data_t), intent(inout) :: md + integer :: iz + class(zone_t), pointer :: z + do iz = 1, md%Nzones + call handle_to_zone(md%zone_handles(iz), z) + call z%calc_all_quants() + end do + end subroutine calc_quants_in_zones + + subroutine save_quants_in_zones(md) + type(mode_data_t), intent(inout) :: md + integer :: iz + class(zone_t), pointer :: z + do iz = 1, md%Nzones + call handle_to_zone(md%zone_handles(iz), z) + call z%save_all_quants() + end do + end subroutine save_quants_in_zones + + !> ---- point lookups (mode_data::determine_zone_index_for_point etc) ---- + + function determine_zone_index_for_point(md, x) result(izz) + type(mode_data_t), intent(in) :: md + real(dp), intent(in) :: x + integer :: izz + integer :: iz + class(zone_t), pointer :: z + logical :: hit + + izz = -1 + do iz = 1, md%Nzones + call handle_to_zone(md%zone_handles(iz), z) + hit = x >= z%get_r1() .and. x <= z%get_r2() + if (hit) then + izz = iz + exit + end if + end do + + if (izz == -1) then + write (*, '(a,es12.4)') & + 'warning: determine_zone_index_for_point: x is outside the grid: x = ', x + izz = 1 + end if + end function determine_zone_index_for_point + + subroutine eval_EB_fields(md, x, EB_out) + type(mode_data_t), intent(in) :: md + real(dp), intent(in) :: x + complex(dp), intent(out) :: EB_out(6) + integer :: izz, D, comp, start + integer(c_int) :: neville_ind + class(zone_t), pointer :: z + real(dp) :: re_v(0:0), im_v(0:0) + + izz = determine_zone_index_for_point(md, x) + call handle_to_zone(md%zone_handles(izz), z) + D = z%get_radial_grid_dimension() + start = md%index(izz) + + neville_ind = 0 + do comp = 1, 6 + call eval_neville_polynom(D, md%r(start + 1:start + D), & + real(md%EB(comp, start + 1:start + D), dp), 5, x, 0, 0, neville_ind, re_v) + call eval_neville_polynom(D, md%r(start + 1:start + D), & + aimag(md%EB(comp, start + 1:start + D)), 5, x, 0, 0, neville_ind, im_v) + EB_out(comp) = cmplx(re_v(0), im_v(0), dp) + end do + end subroutine eval_EB_fields + + !> ---- divEB / calc_and_save_divEB: translated, never invoked (dead in + !> the oracle, gated behind DEBUG_FLAG hard-coded 0) ---- + + subroutine divEB(md, x, div) + type(mode_data_t), intent(in) :: md + real(dp), intent(in) :: x + complex(dp), intent(out) :: div(2) + integer :: izz, D, comp, start + integer(c_int) :: neville_ind + class(zone_t), pointer :: z + real(dp) :: re_v(0:1), im_v(0:1) + complex(dp) :: EBc(6), dEBc(6) + real(dp) :: kt, kz + + izz = determine_zone_index_for_point(md, x) + call handle_to_zone(md%zone_handles(izz), z) + D = z%get_radial_grid_dimension() + start = md%index(izz) + + neville_ind = 0 + do comp = 1, 6 + call eval_neville_polynom(D, md%r(start + 1:start + D), & + real(md%EB(comp, start + 1:start + D), dp), 5, x, 0, 1, neville_ind, re_v) + call eval_neville_polynom(D, md%r(start + 1:start + D), & + aimag(md%EB(comp, start + 1:start + D)), 5, x, 0, 1, neville_ind, im_v) + EBc(comp) = cmplx(re_v(0), im_v(0), dp) + dEBc(comp) = cmplx(re_v(1), im_v(1), dp) + end do + + kt = real(md%wd%m, dp)/x + kz = real(md%wd%n, dp)/get_background_rtor() + + div(1) = EBc(1)/x + dEBc(1) + cmplx(0.0_dp, 1.0_dp, dp)*kt*EBc(2) + & + cmplx(0.0_dp, 1.0_dp, dp)*kz*EBc(3) + div(2) = EBc(4)/x + dEBc(4) + cmplx(0.0_dp, 1.0_dp, dp)*kt*EBc(5) + & + cmplx(0.0_dp, 1.0_dp, dp)*kz*EBc(6) + end subroutine divEB + + subroutine calc_and_save_divEB(md) + type(mode_data_t), intent(in) :: md + character(len=1024) :: fname + integer :: unit, i + complex(dp) :: div(2) + + fname = trim(md%path2linear)//'divEB.dat' + open (newunit=unit, file=trim(fname), status='replace', action='write') + + do i = 1, md%dim + call divEB(md, md%r(i), div) + write (unit, '(es24.16e3,a,es24.16e3,a,es24.16e3,a,es24.16e3,a,es24.16e3)') & + md%r(i), char(9), real(div(1), dp), char(9), aimag(div(1)), char(9), & + real(div(2), dp), char(9), aimag(div(2)) + end do + + close (unit) + end subroutine calc_and_save_divEB + +end module kilca_mode_data_m + +!> Plain (non-module) Fortran subprogram, deliberately kept OUTSIDE +!> kilca_mode_data_m: its only caller, mode_m.f90's own legacy +!> copy_mode_paths_to_mode_data_module, is itself Fortran and reaches it +!> via an implicit external interface (plain `name_` mangling), not a +!> bind(C) name or a module-procedure `__module_MOD_name` mangling - so +!> this must be a free subprogram, not something `contains`ed in a module +!> (a module-contained version compiles fine but produces the wrong +!> symbol name and leaves the real `name_` symbol undefined at link time). +!> That caller (copy_mode_paths_to_mode_data_module) itself has zero +!> callers anywhere in this codebase now (kilca_mode_data_m's own +!> copy_mode_paths_to_mode_data_module_native replaced it for the only +!> call site that mattered), so this body never executes - but gfortran +!> still compiles mode_m.f90's dead subroutine, and the linker still needs +!> this external symbol resolved (it used to be provided by mode.cpp, now +!> deleted). Implemented for real rather than stubbed, since the cost is +!> the same either way and a real implementation can't silently drift +!> from intent. +subroutine copy_mode_paths_from_mode_data_struct(md, path2linear, path2dispersion, & + path2poincare) + use, intrinsic :: iso_c_binding, only: c_intptr_t, c_ptr, c_f_pointer + use kilca_mode_data_m, only: mode_data_t + implicit none + integer(c_intptr_t), intent(in) :: md + character(len=*), intent(out) :: path2linear, path2dispersion, path2poincare + type(mode_data_t), pointer :: mdp + type(c_ptr) :: cp + cp = transfer(md, cp) + call c_f_pointer(cp, mdp) + path2linear = mdp%path2linear + path2dispersion = mdp%path2dispersion + path2poincare = mdp%path2poincare +end subroutine copy_mode_paths_from_mode_data_struct diff --git a/KiLCA/mode/stitching.h b/KiLCA/mode/stitching.h deleted file mode 100644 index af9262cd..00000000 --- a/KiLCA/mode/stitching.h +++ /dev/null @@ -1,24 +0,0 @@ -/*! \file - \brief The declarations of Fortran functions used to build and solve linear system of stitching equations (at zones boundaries). -*/ - -#ifndef STITCHING_INCLUDE - -#define STITCHING_INCLUDE - -/*****************************************************************************/ - -extern "C" -{ -void update_system_matrix_and_rhs_vector_ (int *Nc, double *A, double *B, int *neq, int *ieq, int *nvar, int *ivar, double *M, double *J); - -void calc_system_determinant_ (int *Nc, double *A, double *det); - -void find_superposition_coeffs_ (int *Nc, double *A, double *B, double *S); - -void eval_superposition_of_basis_functions_ (int *D, int *Nw, int *dim, double *basis, double *S, double *EB); -} - -/*****************************************************************************/ - -#endif diff --git a/KiLCA/mode/transforms.cpp b/KiLCA/mode/transforms.cpp deleted file mode 100644 index f8906e74..00000000 --- a/KiLCA/mode/transforms.cpp +++ /dev/null @@ -1,66 +0,0 @@ -/*! \file - \brief The implementation of functions declared in transforms.h. -*/ - -#include "constants.h" -#include "transforms.h" -#include "eval_back.h" - -/*******************************************************************/ - -void galilean_transform_of_EB_fields (complex *EB1, complex *EB2, double V) -{ -//transforms (E, B) fields in cylindrical coordinates -//from a frame 1 to a frame 2 moving with relative velocity V -//Landau II, p. 91 -//E' = E + 1/c V x B, B' = B - 1/c V x E -//E = E' - 1/c V x B', B = B' + 1/c V x E' -//V x A = e_r (-V A_th) + e_th (V A_r) + e_z (0); - -EB2[0] = EB1[0] - (V/c)*EB1[4]; //Er -EB2[1] = EB1[1] + (V/c)*EB1[3]; //Etheta -EB2[2] = EB1[2]; //Ez - -//for consistence, magnetic fields should not transform -EB2[3] = EB1[3]; // + (V/c)*EB1[1]; //Br -EB2[4] = EB1[4]; // - (V/c)*EB1[0]; //Btheta -EB2[5] = EB1[5]; //Bz -} - -/*******************************************************************/ - -void transform_EB_from_cyl_to_rsp (const background *bp, double r, complex *EBcyl, complex *EBrsp) -{ -double htz[2]; - -eval_hthz (r, 0, 0, bp, htz); - -//transform EB from cyl to rsp system: -EBrsp[0] = EBcyl[0]; -EBrsp[1] = htz[1]*EBcyl[1] - htz[0]*EBcyl[2]; -EBrsp[2] = htz[0]*EBcyl[1] + htz[1]*EBcyl[2]; - -EBrsp[3] = EBcyl[3]; -EBrsp[4] = htz[1]*EBcyl[4] - htz[0]*EBcyl[5]; -EBrsp[5] = htz[0]*EBcyl[4] + htz[1]*EBcyl[5]; -} - -/*****************************************************************************/ - -void transform_EB_from_rsp_to_cyl (const background *bp, double r, complex *EBrsp, complex *EBcyl) -{ -double htz[2]; - -eval_hthz (r, 0, 0, bp, htz); - -//transform EB from rsp to cyl system: -EBcyl[0] = EBrsp[0]; -EBcyl[1] = htz[1]*EBrsp[1] + htz[0]*EBrsp[2]; -EBcyl[2] = - htz[0]*EBrsp[1] + htz[1]*EBrsp[2]; - -EBcyl[3] = EBrsp[3]; -EBcyl[4] = htz[1]*EBrsp[4] + htz[0]*EBrsp[5]; -EBcyl[5] = - htz[0]*EBrsp[4] + htz[1]*EBrsp[5]; -} - -/*****************************************************************************/ diff --git a/KiLCA/mode/transforms.h b/KiLCA/mode/transforms.h deleted file mode 100644 index dbdebfcb..00000000 --- a/KiLCA/mode/transforms.h +++ /dev/null @@ -1,25 +0,0 @@ -/*! \file - \brief The declarations of functions for transformations of fields. -*/ - -#ifndef TRANSFORMS_INCLUDE - -#define TRANSFORMS_INCLUDE - -#include - -#include "background.h" - -using namespace std; - -/*******************************************************************/ - -void galilean_transform_of_EB_fields (complex *EB1, complex *EB2, double V); - -void transform_EB_from_cyl_to_rsp (const background *bp, double r, complex *EBcyl, complex *EBrsp); - -void transform_EB_from_rsp_to_cyl (const background *bp, double r, complex *EBrsp, complex *EBcyl); - -/*******************************************************************/ - -#endif diff --git a/KiLCA/mode/transforms_m.f90 b/KiLCA/mode/transforms_m.f90 new file mode 100644 index 00000000..bc7ed606 --- /dev/null +++ b/KiLCA/mode/transforms_m.f90 @@ -0,0 +1,89 @@ +!> Field-frame and coordinate transforms, formerly transforms.{h,cpp}. +!> bind(C) (no trailing underscore, matching the oracle's plain C++ function +!> names - transforms.h never wrapped them in extern "C", but nothing relied +!> on C++ name mangling either, so giving them C linkage here is a safe, +!> behavior-preserving choice): called both from native Fortran (flre_zone, +!> also part of this port) and from still-C++ wave_code_interface.cpp (S7). +!> bp is kept as a parameter for call-site fidelity but ignored, matching +!> every other post-singleton background handle in this port (background is +!> a Fortran singleton; see kilca_background_data_m). +module kilca_transforms_m + use, intrinsic :: iso_c_binding, only: c_intptr_t, c_double, c_double_complex, c_null_ptr + use constants, only: dp + use kilca_background_data_m, only: eval_hthz_native => eval_hthz + implicit none + private + + !> Speed of light at full double precision, mirroring the C++ oracle's + !> constants.h that this ported code descends from. The Fortran constants + !> module keeps a legacy single-precision c for its own physics. + real(dp), parameter :: c = 29979245800.0_dp + + public :: galilean_transform_of_EB_fields + public :: transform_EB_from_cyl_to_rsp + public :: transform_EB_from_rsp_to_cyl + +contains + + !> Transforms (E, B) fields in cylindrical coordinates from a frame 1 to + !> a frame 2 moving with relative velocity V. Landau II, p. 91: + !> E' = E + 1/c V x B, B' = B - 1/c V x E + !> E = E' - 1/c V x B', B = B' + 1/c V x E' + !> V x A = e_r (-V A_th) + e_th (V A_r) + e_z (0) + subroutine galilean_transform_of_EB_fields(EB1, EB2, V) & + bind(C, name="galilean_transform_of_EB_fields") + complex(c_double_complex), intent(in) :: EB1(6) + complex(c_double_complex), intent(out) :: EB2(6) + real(c_double), value :: V + + EB2(1) = EB1(1) - (V/c)*EB1(5) !Er + EB2(2) = EB1(2) + (V/c)*EB1(4) !Etheta + EB2(3) = EB1(3) !Ez + + !for consistence, magnetic fields should not transform + EB2(4) = EB1(4) ! + (V/c)*EB1(2); !Br + EB2(5) = EB1(5) ! - (V/c)*EB1(1); !Btheta + EB2(6) = EB1(6) !Bz + end subroutine galilean_transform_of_EB_fields + + subroutine transform_EB_from_cyl_to_rsp(bp, rval, EBcyl, EBrsp) & + bind(C, name="transform_EB_from_cyl_to_rsp") + integer(c_intptr_t), value :: bp + real(c_double), value :: rval + complex(c_double_complex), intent(in) :: EBcyl(6) + complex(c_double_complex), intent(out) :: EBrsp(6) + real(dp) :: htz(0:1) + + call eval_hthz_native(rval, 0, 0, c_null_ptr, htz) + + !transform EB from cyl to rsp system: + EBrsp(1) = EBcyl(1) + EBrsp(2) = htz(1)*EBcyl(2) - htz(0)*EBcyl(3) + EBrsp(3) = htz(0)*EBcyl(2) + htz(1)*EBcyl(3) + + EBrsp(4) = EBcyl(4) + EBrsp(5) = htz(1)*EBcyl(5) - htz(0)*EBcyl(6) + EBrsp(6) = htz(0)*EBcyl(5) + htz(1)*EBcyl(6) + end subroutine transform_EB_from_cyl_to_rsp + + subroutine transform_EB_from_rsp_to_cyl(bp, rval, EBrsp, EBcyl) & + bind(C, name="transform_EB_from_rsp_to_cyl") + integer(c_intptr_t), value :: bp + real(c_double), value :: rval + complex(c_double_complex), intent(in) :: EBrsp(6) + complex(c_double_complex), intent(out) :: EBcyl(6) + real(dp) :: htz(0:1) + + call eval_hthz_native(rval, 0, 0, c_null_ptr, htz) + + !transform EB from rsp to cyl system: + EBcyl(1) = EBrsp(1) + EBcyl(2) = htz(1)*EBrsp(2) + htz(0)*EBrsp(3) + EBcyl(3) = -htz(0)*EBrsp(2) + htz(1)*EBrsp(3) + + EBcyl(4) = EBrsp(4) + EBcyl(5) = htz(1)*EBrsp(5) + htz(0)*EBrsp(6) + EBcyl(6) = -htz(0)*EBrsp(5) + htz(1)*EBrsp(6) + end subroutine transform_EB_from_rsp_to_cyl + +end module kilca_transforms_m diff --git a/KiLCA/mode/wave_data.h b/KiLCA/mode/wave_data.h deleted file mode 100644 index 6af05f2f..00000000 --- a/KiLCA/mode/wave_data.h +++ /dev/null @@ -1,43 +0,0 @@ -/*! \file - \brief The declaration of wave_data class. -*/ - -#ifndef WAVE_DATA_INCLUDE - -#define WAVE_DATA_INCLUDE - -#include - -/*-----------------------------------------------------------------*/ - -/*! \class wave_data - \brief Class describes the properties of a perturbation mode. -*/ -class wave_data -{ -public: - int m; //! olab; //! omov; //! det; //! olab1, complex omov1) - { - m = m1; - n = n1; - olab = olab1; - omov = omov1; - } - - ~wave_data (void) {} -}; - -/*-----------------------------------------------------------------*/ - -#endif diff --git a/KiLCA/mode/wave_data_m.f90 b/KiLCA/mode/wave_data_m.f90 new file mode 100644 index 00000000..e0a8e21b --- /dev/null +++ b/KiLCA/mode/wave_data_m.f90 @@ -0,0 +1,163 @@ +!> Per-mode wave description (harmonics, frequency, resonance location, +!> stitching determinant), formerly the C++ wave_data class. Per-instance +!> handle (same pattern as kilca_cond_profiles_m/kilca_background_data_m's +!> sibling modules): one wave_data per mode_data, shared by all zones of +!> that mode. mode_data (mode.cpp, still C++ until S6) owns the lifetime; +!> the legacy mode_data Fortran module (mode_m.f90) and the new zone_t +!> hierarchy both hold the same opaque handle, exactly as they held the raw +!> C++ pointer before. +module kilca_wave_data_m + use, intrinsic :: iso_c_binding, only: c_int, c_intptr_t, c_double, c_ptr, & + c_loc, c_f_pointer + implicit none + private + + public :: wave_data_t + public :: wave_data_create, wave_data_destroy + public :: wave_data_get_m, wave_data_get_n + public :: wave_data_get_olab_re, wave_data_get_olab_im + public :: wave_data_get_r_res, wave_data_set_r_res + public :: wave_data_get_det_re, wave_data_get_det_im + public :: get_wave_data_obj_omov_re, get_wave_data_obj_omov_im + public :: set_det_in_wd_struct + + type :: wave_data_t + integer(c_int) :: m, n + complex(c_double) :: olab, omov, det + real(c_double) :: r_res + end type wave_data_t + +contains + + function wave_data_create(m, n, olab_re, olab_im, omov_re, omov_im) & + result(handle) bind(C, name="wave_data_create_") + integer(c_int), value :: m, n + real(c_double), value :: olab_re, olab_im, omov_re, omov_im + integer(c_intptr_t) :: handle + type(wave_data_t), pointer :: wd + + allocate (wd) + wd%m = m + wd%n = n + wd%olab = cmplx(olab_re, olab_im, c_double) + wd%omov = cmplx(omov_re, omov_im, c_double) + wd%r_res = 0.0d0 + wd%det = (0.0d0, 0.0d0) + + handle = transfer(c_loc(wd), handle) + end function wave_data_create + + subroutine wave_data_destroy(handle) bind(C, name="wave_data_destroy_") + integer(c_intptr_t), value :: handle + type(wave_data_t), pointer :: wd + + if (handle == 0_c_intptr_t) return + call handle_to_wd(handle, wd) + deallocate (wd) + end subroutine wave_data_destroy + + function wave_data_get_m(handle) result(res) bind(C, name="wave_data_get_m_") + type(c_ptr), value :: handle + integer(c_int) :: res + type(wave_data_t), pointer :: wd + call c_f_pointer(handle, wd) + res = wd%m + end function wave_data_get_m + + function wave_data_get_n(handle) result(res) bind(C, name="wave_data_get_n_") + type(c_ptr), value :: handle + integer(c_int) :: res + type(wave_data_t), pointer :: wd + call c_f_pointer(handle, wd) + res = wd%n + end function wave_data_get_n + + function wave_data_get_olab_re(handle) result(res) bind(C, name="wave_data_get_olab_re_") + type(c_ptr), value :: handle + real(c_double) :: res + type(wave_data_t), pointer :: wd + call c_f_pointer(handle, wd) + res = real(wd%olab, c_double) + end function wave_data_get_olab_re + + function wave_data_get_olab_im(handle) result(res) bind(C, name="wave_data_get_olab_im_") + type(c_ptr), value :: handle + real(c_double) :: res + type(wave_data_t), pointer :: wd + call c_f_pointer(handle, wd) + res = aimag(wd%olab) + end function wave_data_get_olab_im + + function wave_data_get_r_res(handle) result(res) bind(C, name="wave_data_get_r_res_") + type(c_ptr), value :: handle + real(c_double) :: res + type(wave_data_t), pointer :: wd + call c_f_pointer(handle, wd) + res = wd%r_res + end function wave_data_get_r_res + + subroutine wave_data_set_r_res(handle, val) bind(C, name="wave_data_set_r_res_") + type(c_ptr), value :: handle + real(c_double), value :: val + type(wave_data_t), pointer :: wd + call c_f_pointer(handle, wd) + wd%r_res = val + end subroutine wave_data_set_r_res + + function wave_data_get_det_re(handle) result(res) bind(C, name="wave_data_get_det_re_") + type(c_ptr), value :: handle + real(c_double) :: res + type(wave_data_t), pointer :: wd + call c_f_pointer(handle, wd) + res = real(wd%det, c_double) + end function wave_data_get_det_re + + function wave_data_get_det_im(handle) result(res) bind(C, name="wave_data_get_det_im_") + type(c_ptr), value :: handle + real(c_double) :: res + type(wave_data_t), pointer :: wd + call c_f_pointer(handle, wd) + res = aimag(wd%det) + end function wave_data_get_det_im + + !> Pre-existing names/by-value c_ptr convention, called from Fortran + !> (kilca_cond_profiles_m's per-point fallback path). + function get_wave_data_obj_omov_re(handle) result(res) & + bind(C, name="get_wave_data_obj_omov_re_") + type(c_ptr), value :: handle + real(c_double) :: res + type(wave_data_t), pointer :: wd + call c_f_pointer(handle, wd) + res = real(wd%omov, c_double) + end function get_wave_data_obj_omov_re + + function get_wave_data_obj_omov_im(handle) result(res) & + bind(C, name="get_wave_data_obj_omov_im_") + type(c_ptr), value :: handle + real(c_double) :: res + type(wave_data_t), pointer :: wd + call c_f_pointer(handle, wd) + res = aimag(wd%omov) + end function get_wave_data_obj_omov_im + + !> Pre-existing name, BY-REFERENCE handle (Fortran caller convention): + !> the legacy stitching-equations Fortran (calc_system_determinant_) + !> calls this with the handle held in mode_m.f90's wd_ptr. + subroutine set_det_in_wd_struct(wd_ptr, re_det, im_det) & + bind(C, name="set_det_in_wd_struct_") + integer(c_intptr_t), intent(in) :: wd_ptr + real(c_double), intent(in) :: re_det, im_det + type(wave_data_t), pointer :: wd + call handle_to_wd(wd_ptr, wd) + wd%det = cmplx(re_det, im_det, c_double) + end subroutine set_det_in_wd_struct + + subroutine handle_to_wd(handle, wd) + integer(c_intptr_t), value :: handle + type(wave_data_t), pointer, intent(out) :: wd + type(c_ptr) :: cwd + cwd = transfer(handle, cwd) + call c_f_pointer(cwd, wd) + end subroutine handle_to_wd + +end module kilca_wave_data_m diff --git a/KiLCA/mode/zone.cpp b/KiLCA/mode/zone.cpp deleted file mode 100644 index 9981f759..00000000 --- a/KiLCA/mode/zone.cpp +++ /dev/null @@ -1,393 +0,0 @@ -/*! \file - \brief The implementation of zone class. -*/ - -#include -#include -#include -#include -#include -#include - -#include "zone.h" -#include "shared.h" -#include "inout.h" -#include "constants.h" -#include "mode.h" -#include "stitching.h" - -/*****************************************************************************/ - -zone::zone (const settings *sd_p, const background *bp_p, const wave_data *wd_p, char *path_p, int index_p) -{ -sd = sd_p; -bp = bp_p; -wd = wd_p; - -path = new char[1024]; -strcpy (path, path_p); - -index = index_p; - -r = 0; -basis = 0; -EB = 0; -S = 0; -} - -/*****************************************************************************/ - -zone::~zone () -{ -delete [] path; - -delete [] r; -delete [] basis; -delete [] EB; -delete [] S; -} - -/*****************************************************************************/ - -void zone::read (char *file) -{ -FILE *in; - -if ((in=fopen (file, "r"))==NULL) -{ - fprintf(stderr, "\nerror: read_settings: failed to open file %s\a\n", file); - exit(0); -} - -//string buffers: -char *str_buf = new char[1024]; -char *bstr1 = new char[64]; -char *bstr2 = new char[64]; -char *mstr = new char[64]; - -read_line_2skip_it (in, &str_buf); -read_line_2get_double (in, &r1); -read_line_2get_string (in, &bstr1); -read_line_2get_string (in, &mstr); -read_line_2get_int (in, &version); -read_line_2get_string (in, &bstr2); -read_line_2get_double (in, &r2); -read_line_2skip_it (in, &str_buf); - -fclose (in); - -//Determination of BC type index: -bc1 = -1; -bc2 = -1; -for (int k=0; kd_name, 0)) return 1; -else return 0; -} - -/*******************************************************************/ - -int determine_number_of_zones (char *path2project) -{ -//determines number of zones: 2 versions: scandir() and readdir() - -//struct dirent **all; - -//int Nzones = scandir (path2project, &all, selector, alphasort); - -int Nzones = 0; - -DIR *dp; -struct dirent *ep; - -if (dp = opendir (path2project)) -{ - while (ep = readdir (dp)) - { - if (!fnmatch ("zone_*.in", ep->d_name, 0)) Nzones++; - } - closedir (dp); -} -else -{ - fprintf(stderr, "\ndetermine_number_of_zones: faled to open the project directory %s", path2project); - exit(1); -} - -if (DEBUG_FLAG) -{ - fprintf (stdout, "\nNzones = %d", Nzones); fflush (stdout); -} - -return Nzones; -} - -/*******************************************************************/ - -char * get_zone_file_name (char * path2project, int zone_index) -{ -DIR * dp; -struct dirent * ep; - -char * file_name = new char[1024]; - -strcpy (file_name, path2project); - -int count = 0; - -if (dp = opendir (path2project)) -{ - char * file_pattern = new char[1024]; - - sprintf (file_pattern, "*zone_%d*.in", zone_index+1); - - while (ep = readdir (dp)) - { - if (!fnmatch (file_pattern, ep->d_name, 0)) - { - ++count; - strcat (file_name, ep->d_name); - break; - } - } - closedir (dp); - delete [] file_pattern; -} -else -{ - fprintf (stderr, "\nget_zone_file_name: faled to open the project directory %s", path2project); - exit (1); -} - -if (DEBUG_FLAG) -{ - fprintf (stdout, "\nget_zone_file_name: file name for zone %d is: %s", zone_index, file_name); - fflush (stdout); -} - -if (!count) -{ - fprintf (stderr, "\nget_zone_file_name: failed to find the file name for zone %d!", zone_index); - delete [] file_name; - exit (1); -} - -return file_name; -} - -/*******************************************************************/ - -void zone::calc_superposition_of_basis_fields (double *S_p) -{ -EB = new double[dim*Ncomps*2]; - -S = new double[Nwaves*2]; - -for (int i=0; iget_r2 (); -} - -/*****************************************************************************/ - -void get_left_boundary_of_zone_ (zone **ptr, double *r) -{ -zone *Z = (zone *)(*ptr); - -*r = Z->get_r1 (); -} - -/*****************************************************************************/ diff --git a/KiLCA/mode/zone.h b/KiLCA/mode/zone.h deleted file mode 100644 index e1f897d4..00000000 --- a/KiLCA/mode/zone.h +++ /dev/null @@ -1,185 +0,0 @@ -/*! \file - \brief The declaration of zone class - the basic class for all types of zones. -*/ - -#ifndef ZONE_INCLUDE - -#define ZONE_INCLUDE - -/*******************************************************************/ - -#include "settings.h" -#include "background.h" -#include "wave_data.h" - -/*******************************************************************/ - -#define PLASMA_MODEL_VACUUM 0 -#define PLASMA_MODEL_MEDIUM 1 -#define PLASMA_MODEL_IMHD 2 -#define PLASMA_MODEL_RMHD 3 -#define PLASMA_MODEL_FLRE 4 - -#define BOUNDARY_CENTER 0 -#define BOUNDARY_INFINITY 1 -#define BOUNDARY_IDEALWALL 2 -#define BOUNDARY_INTERFACE 3 -#define BOUNDARY_ANTENNA 4 - -/*******************************************************************/ - -const int Nbc = 5; -const char bc_str[Nbc][64] = {{"center"}, {"infinity"}, {"idealwall"}, {"interface"}, {"antenna"}}; - -const int Nmed = 5; -const char med_str[Nmed][64] = {{"vacuum"}, {"medium"}, {"imhd"}, {"rmhd"}, {"flre"}}; - -/*******************************************************************/ - -/*! \class zone - \brief This basic class for all types of zones describes the zone - an interval over radius where a particular plasma model is used. -*/ -class zone -{ -public: - double r1; //! Abstract base for the zone hierarchy (zone.h/zone.cpp), a radial +!> interval over which one plasma model (vacuum/medium/imhd/flre) is +!> solved. F2003 type-extension polymorphism: concrete subtypes +!> hmedium_zone_t/imhd_zone_t/flre_zone_t (kilca_hmedium_zone_m/ +!> kilca_imhd_zone_m/kilca_flre_zone_m) extend zone_t and override the +!> deferred bindings below. +!> +!> sd (settings*) is write-only at construction in the C++ oracle (zone.cpp +!> never dereferences it; `path` already holds a copy of sd->path2project), +!> so it is accepted by the create shims for ABI/call-site fidelity but not +!> stored. bp (background*) IS read by several subclasses (imhd_zone.cpp, +!> incompressible.cpp, compressible_flow.cpp, flre_zone.cpp all pass +!> `zone->bp` into eval_* calls), but background is now a Fortran singleton +!> (kilca_background_data_m) whose handle value is always ignored, so bp is +!> kept only as a pass-through sentinel for call-site shape fidelity. +!> +!> mode_data (mode.cpp/calc_mode.cpp, still C++ until S6) cannot hold or +!> dispatch through a class(zone_t) directly, so this module also exports a +!> bind(C) dispatch-shim layer: one zone__ function per +!> deferred/concrete binding, taking an opaque handle, recovering a +!> class(zone_t) pointer via c_f_pointer, and making a normal type-bound +!> call (dispatched by the compiler to the right override). Per-subtype +!> _zone_create_ factories (in each subtype's own module) return that +!> handle. This shim is temporary: S6 removes it once mode_data itself +!> becomes Fortran and can hold class(zone_t) natively. +module kilca_zone_m + use, intrinsic :: iso_c_binding, only: c_int, c_intptr_t, c_double, c_char, & + c_ptr, c_loc, c_f_pointer, c_null_char + use constants, only: dp + use kilca_wave_data_m, only: wave_data_t + use kilca_shared_m, only: strtol_int + implicit none + private + + public :: zone_t + public :: PLASMA_MODEL_VACUUM, PLASMA_MODEL_MEDIUM, PLASMA_MODEL_IMHD, & + PLASMA_MODEL_RMHD, PLASMA_MODEL_FLRE + public :: BOUNDARY_CENTER, BOUNDARY_INFINITY, BOUNDARY_IDEALWALL, & + BOUNDARY_INTERFACE, BOUNDARY_ANTENNA + public :: bc_str, med_str, Nbc, Nmed + public :: zone_read, zone_print + public :: zone_register, handle_to_zone + public :: skip_line, read_real_before_hash, read_int_before_hash + public :: read_token_before_hash, read_complex_before_hash + + public :: zone_read_settings_c, zone_print_settings_c, zone_calc_basis_fields_c + public :: zone_copy_E_and_B_fields_c, zone_calc_final_fields_c + public :: zone_calc_dispersion_c, zone_save_dispersion_c + public :: zone_calc_all_quants_c, zone_save_all_quants_c + public :: zone_eval_diss_power_density_c, zone_eval_current_density_c + public :: zone_get_r1_c, zone_get_r2_c + public :: zone_get_dim_of_basis_c, zone_get_dim_of_basis_vector_c + public :: zone_get_radial_grid_dimension_c, zone_get_code_version_c + public :: zone_get_medium_c, zone_get_bc1_c, zone_get_bc2_c + public :: zone_get_basis_at_left_boundary_c, zone_get_basis_at_right_boundary_c + public :: zone_save_basis_fields_c, zone_calc_superposition_of_basis_fields_c + public :: zone_save_final_fields_c, zone_copy_radial_grid_c + public :: zone_destroy_c + public :: get_right_boundary_of_zone, get_left_boundary_of_zone + + integer, parameter :: PLASMA_MODEL_VACUUM = 0 + integer, parameter :: PLASMA_MODEL_MEDIUM = 1 + integer, parameter :: PLASMA_MODEL_IMHD = 2 + integer, parameter :: PLASMA_MODEL_RMHD = 3 + integer, parameter :: PLASMA_MODEL_FLRE = 4 + + integer, parameter :: BOUNDARY_CENTER = 0 + integer, parameter :: BOUNDARY_INFINITY = 1 + integer, parameter :: BOUNDARY_IDEALWALL = 2 + integer, parameter :: BOUNDARY_INTERFACE = 3 + integer, parameter :: BOUNDARY_ANTENNA = 4 + + integer, parameter :: Nbc = 5 + character(len=16), parameter :: bc_str(0:Nbc - 1) = & + [character(len=16) :: 'center', 'infinity', 'idealwall', 'interface', 'antenna'] + integer, parameter :: Nmed = 5 + character(len=16), parameter :: med_str(0:Nmed - 1) = & + [character(len=16) :: 'vacuum', 'medium', 'imhd', 'rmhd', 'flre'] + + type, abstract :: zone_t + real(dp) :: r1 = 0, r2 = 0 + integer :: bc1 = -1, bc2 = -1 + integer :: medium = -1, version = 0 + integer :: index = 0 + integer(c_intptr_t) :: bp = 1_c_intptr_t + type(wave_data_t), pointer :: wd => null() + character(len=1024) :: path = '' + integer :: dim = 0 + real(dp), allocatable :: r(:) + complex(dp), allocatable :: basis(:, :, :) + complex(dp), allocatable :: EB(:, :) + complex(dp), allocatable :: S(:) + integer :: Nwaves = 0, Ncomps = 0 + integer :: max_dim = 0 + real(dp) :: eps_rel = 0, eps_abs = 0 + integer :: deg = 0 + real(dp) :: reps = 0, aeps = 0, step = 0 + integer :: flag_debug = 0 + contains + procedure :: get_r1 => zone_get_r1 + procedure :: get_r2 => zone_get_r2 + procedure :: get_dim_of_basis => zone_get_dim_of_basis + procedure :: get_dim_of_basis_vector => zone_get_dim_of_basis_vector + procedure :: get_code_version => zone_get_code_version + procedure :: get_radial_grid_dimension => zone_get_radial_grid_dimension + procedure :: save_basis_fields => zone_save_basis_fields + procedure :: calc_superposition_of_basis_fields => zone_calc_superposition_of_basis_fields + procedure :: save_final_fields => zone_save_final_fields + procedure :: copy_radial_grid => zone_copy_radial_grid + + procedure(read_settings_if), deferred :: read_settings + procedure(print_settings_if), deferred :: print_settings + procedure(calc_basis_fields_if), deferred :: calc_basis_fields + procedure(copy_E_and_B_fields_if), deferred :: copy_E_and_B_fields + procedure(calc_final_fields_if), deferred :: calc_final_fields + procedure(calc_dispersion_if), deferred :: calc_dispersion + procedure(save_dispersion_if), deferred :: save_dispersion + procedure(calc_all_quants_if), deferred :: calc_all_quants + procedure(save_all_quants_if), deferred :: save_all_quants + procedure(eval_diss_power_density_if), deferred :: eval_diss_power_density + procedure(eval_current_density_if), deferred :: eval_current_density + end type zone_t + + abstract interface + subroutine read_settings_if(self, file) + import :: zone_t + class(zone_t), intent(inout) :: self + character(len=*), intent(in) :: file + end subroutine read_settings_if + + subroutine print_settings_if(self) + import :: zone_t + class(zone_t), intent(in) :: self + end subroutine print_settings_if + + subroutine calc_basis_fields_if(self, flag) + import :: zone_t + class(zone_t), intent(inout) :: self + integer, intent(in) :: flag + end subroutine calc_basis_fields_if + + subroutine copy_E_and_B_fields_if(self, EB_out) + import :: zone_t, dp + class(zone_t), intent(in) :: self + real(dp), intent(out) :: EB_out(*) + end subroutine copy_E_and_B_fields_if + + subroutine calc_final_fields_if(self) + import :: zone_t + class(zone_t), intent(inout) :: self + end subroutine calc_final_fields_if + + subroutine calc_dispersion_if(self) + import :: zone_t + class(zone_t), intent(inout) :: self + end subroutine calc_dispersion_if + + subroutine save_dispersion_if(self) + import :: zone_t + class(zone_t), intent(inout) :: self + end subroutine save_dispersion_if + + subroutine calc_all_quants_if(self) + import :: zone_t + class(zone_t), intent(inout) :: self + end subroutine calc_all_quants_if + + subroutine save_all_quants_if(self) + import :: zone_t + class(zone_t), intent(inout) :: self + end subroutine save_all_quants_if + + subroutine eval_diss_power_density_if(self, x, ttype, spec, dpd) + import :: zone_t, dp + class(zone_t), intent(in) :: self + real(dp), intent(in) :: x + integer, intent(in) :: ttype, spec + real(dp), intent(out) :: dpd(*) + end subroutine eval_diss_power_density_if + + subroutine eval_current_density_if(self, x, ttype, spec, comp, J) + import :: zone_t, dp + class(zone_t), intent(in) :: self + real(dp), intent(in) :: x + integer, intent(in) :: ttype, spec, comp + real(dp), intent(out) :: J(*) + end subroutine eval_current_density_if + end interface + + interface + subroutine eval_superposition_of_basis_functions(D, Nw, ndim, basis, S, EB) + import :: dp + integer, intent(in) :: D, Nw, ndim + complex(dp), intent(in) :: basis(D, Nw, ndim) + complex(dp), intent(in) :: S(Nw) + complex(dp), intent(out) :: EB(D, ndim) + end subroutine eval_superposition_of_basis_functions + end interface + + !> c_loc/transfer cannot recover a polymorphic dynamic type from a bare + !> address (the C pointer carries no type-descriptor information), so + !> handles are plain 1-based indices into this fixed-size pool instead + !> of memory addresses. Sized far above any plausible Nzones (single + !> digits to a few dozen per mode, a handful of modes per run). + integer, parameter :: max_zones = 4096 + type :: zone_box_t + class(zone_t), pointer :: z => null() + end type zone_box_t + type(zone_box_t) :: zone_pool(max_zones) + integer :: zone_pool_size = 0 + +contains + + !> Replicates zone::read: 8 lines (skip, r1, bc1-string, medium-string, + !> version, bc2-string, r2, skip), each value taken as the text before + !> '#' (matching read_line_2get_*'s strtok(buf, "#\n\0") convention). + subroutine zone_read(self, file) + class(zone_t), intent(inout) :: self + character(len=*), intent(in) :: file + integer :: unit, ios, k + character(len=1024) :: line + character(len=64) :: bstr1, bstr2, mstr + + open (newunit=unit, file=trim(file), status='old', action='read', iostat=ios) + if (ios /= 0) then + write (*, '(a,a)') 'error: read_settings: failed to open file ', trim(file) + stop 1 + end if + + read (unit, '(a)') line + call read_real_before_hash(unit, self%r1) + call read_token_before_hash(unit, bstr1) + call read_token_before_hash(unit, mstr) + call read_int_before_hash(unit, self%version) + call read_token_before_hash(unit, bstr2) + call read_real_before_hash(unit, self%r2) + read (unit, '(a)') line + + close (unit) + + self%bc1 = -1 + self%bc2 = -1 + do k = 0, Nbc - 1 + if (trim(bstr1) == trim(bc_str(k))) self%bc1 = k + if (trim(bstr2) == trim(bc_str(k))) self%bc2 = k + end do + + if (self%bc1 == -1 .or. self%bc2 == -1) then + write (*, '(a,a,a,a)') 'zone::read: BC type is not known: ', trim(bstr1), ' ', trim(bstr2) + stop 1 + end if + + self%medium = -1 + do k = 0, Nmed - 1 + if (trim(mstr) == trim(med_str(k))) then + self%medium = k + exit + end if + end do + + if (self%medium == -1) then + write (*, '(a,a)') 'zone::read: medium type is not known: ', trim(mstr) + stop 1 + end if + end subroutine zone_read + + !> Mirrors read_line_2get_double_'s tolerance: a short/failed line read + !> (EOF) or an unparseable value-before-hash leaves val at 0.0 rather + !> than aborting, matching the oracle's getline/strtod-based reader + !> which only warns to stderr and continues. + subroutine read_real_before_hash(unit, val) + integer, intent(in) :: unit + real(dp), intent(out) :: val + character(len=1024) :: line + integer :: ipos, jos + read (unit, '(a)', iostat=jos) line + if (jos /= 0) line = '' + ipos = index(line, '#') + if (ipos == 0) ipos = len_trim(line) + 1 + read (line(1:ipos - 1), *, iostat=jos) val + if (jos /= 0) val = 0.0_dp + end subroutine read_real_before_hash + + !> Mirrors read_line_2get_int_'s exact C strtol(s, NULL, 10) semantics + !> (kilca_shared_m::strtol_int) rather than a clean Fortran integer + !> read: some zone_N.in fields declared as integers (e.g. flre_zone's + !> max_dim) are written in the file using scientific-notation float + !> literals like "1.00e+05" - the oracle's strtol-based reader silently + !> truncates that to the leading digit run (1), and this port's + !> translation must reproduce that truncation bit-for-bit rather than + !> erroring out (a plain Fortran list-directed integer read rejects + !> "1.00e+05" outright) or "properly" parsing the full float literal. + !> A short/failed line read (EOF) leaves val at 0, matching the + !> oracle's tolerant getline-based reader. + subroutine read_int_before_hash(unit, val) + integer, intent(in) :: unit + integer, intent(out) :: val + character(len=1024) :: line + integer :: ipos, jos + read (unit, '(a)', iostat=jos) line + if (jos /= 0) line = '' + ipos = index(line, '#') + if (ipos == 0) ipos = len_trim(line) + 1 + val = strtol_int(line(1:ipos - 1)) + end subroutine read_int_before_hash + + subroutine read_token_before_hash(unit, val) + integer, intent(in) :: unit + character(len=*), intent(out) :: val + character(len=1024) :: line + integer :: ipos, jos + read (unit, '(a)', iostat=jos) line + if (jos /= 0) line = '' + ipos = index(line, '#') + if (ipos == 0) ipos = len_trim(line) + 1 + val = '' + if (len_trim(line(1:ipos - 1)) > 0) read (line(1:ipos - 1), *, iostat=jos) val + end subroutine read_token_before_hash + + !> Matches read_line_2get_complex: the text before '#' is "(re,im)". A + !> short/failed line read (EOF) or unparseable content leaves val at + !> (0,0), matching the oracle's tolerant getline-based reader. + subroutine read_complex_before_hash(unit, val) + integer, intent(in) :: unit + complex(dp), intent(out) :: val + character(len=1024) :: line + integer :: ipos, p1, p2, p3, jos + real(dp) :: re, im + read (unit, '(a)', iostat=jos) line + if (jos /= 0) line = '' + ipos = index(line, '#') + if (ipos == 0) ipos = len_trim(line) + 1 + p1 = index(line(1:ipos - 1), '(') + p2 = index(line(1:ipos - 1), ',') + p3 = index(line(1:ipos - 1), ')') + re = 0.0_dp + im = 0.0_dp + if (p1 > 0 .and. p2 > p1 .and. p3 > p2) then + read (line(p1 + 1:p2 - 1), *, iostat=jos) re + if (jos /= 0) re = 0.0_dp + read (line(p2 + 1:p3 - 1), *, iostat=jos) im + if (jos /= 0) im = 0.0_dp + end if + val = cmplx(re, im, dp) + end subroutine read_complex_before_hash + + !> Mirrors read_line_2skip_it_: the oracle's getline-based reader only + !> warns to stderr on a short/failed read (`if (getline(...) < 2) + !> fprintf(stderr, ...)`), it never aborts - a caller can legitimately + !> skip_line past true EOF (e.g. a zone_N.in with no trailing blank + !> line after its last data field) and the oracle just continues with + !> whatever settings it already parsed. A bare `read` here would abort + !> the whole program on that same input, which is not bit-identical. + subroutine skip_line(unit) + integer, intent(in) :: unit + character(len=1024) :: line + integer :: jos + read (unit, '(a)', iostat=jos) line + end subroutine skip_line + + subroutine zone_print(self) + class(zone_t), intent(in) :: self + write (*, '(a,i0)') 'zone index = ', self%index + write (*, '(a,es24.16e3)') 'r1 = ', self%r1 + write (*, '(a,es24.16e3)') 'r2 = ', self%r2 + write (*, '(a,i0)') 'bc1 = ', self%bc1 + write (*, '(a,i0)') 'bc2 = ', self%bc2 + write (*, '(a,i0)') 'medium = ', self%medium + write (*, '(a,i0)') 'version = ', self%version + write (*, '(a,i0)') 'number of waves: ', self%Nwaves + write (*, '(a,i0)') 'number of field components: ', self%Ncomps + write (*, '(a,i0)') 'max dimension of the radial grid for the solution: ', self%max_dim + write (*, '(a,es16.8e3)') 'relative accuracy for the solver: ', self%eps_rel + write (*, '(a,es16.8e3)') 'absolute accuracy for the solver: ', self%eps_abs + write (*, '(a,i0)') 'degree of the polynomial used to space out the solution: ', self%deg + write (*, '(a,es16.8e3)') 'relative accuracy of the sparse solution: ', self%reps + write (*, '(a,es16.8e3)') 'absolute accuracy of the sparse solution: ', self%aeps + write (*, '(a,es16.8e3)') 'max grid step in the solution: ', self%step + write (*, '(a,i0)') 'flag for debugging mode: ', self%flag_debug + end subroutine zone_print + + real(dp) function zone_get_r1(self) result(res) + class(zone_t), intent(in) :: self + res = self%r1 + end function zone_get_r1 + + real(dp) function zone_get_r2(self) result(res) + class(zone_t), intent(in) :: self + res = self%r2 + end function zone_get_r2 + + integer function zone_get_dim_of_basis(self) result(res) + class(zone_t), intent(in) :: self + res = self%Nwaves + end function zone_get_dim_of_basis + + integer function zone_get_dim_of_basis_vector(self) result(res) + class(zone_t), intent(in) :: self + res = self%Ncomps + end function zone_get_dim_of_basis_vector + + integer function zone_get_code_version(self) result(res) + class(zone_t), intent(in) :: self + res = self%version + end function zone_get_code_version + + integer function zone_get_radial_grid_dimension(self) result(res) + class(zone_t), intent(in) :: self + res = self%dim + end function zone_get_radial_grid_dimension + + subroutine zone_calc_superposition_of_basis_fields(self, S_p) + class(zone_t), intent(inout) :: self + real(dp), intent(in) :: S_p(0:2*self%Nwaves - 1) + integer :: i + + if (allocated(self%EB)) deallocate (self%EB) + allocate (self%EB(self%Ncomps, self%dim)) + + if (allocated(self%S)) deallocate (self%S) + allocate (self%S(self%Nwaves)) + + do i = 1, self%Nwaves + self%S(i) = cmplx(S_p(2*(i - 1)), S_p(2*(i - 1) + 1), dp) + end do + + call eval_superposition_of_basis_functions(self%Ncomps, self%Nwaves, self%dim, self%basis, self%S, self%EB) + end subroutine zone_calc_superposition_of_basis_fields + + subroutine zone_copy_radial_grid(self, r_p) + class(zone_t), intent(in) :: self + real(dp), intent(out) :: r_p(*) + integer :: i + do i = 1, self%dim + r_p(i) = self%r(i) + end do + end subroutine zone_copy_radial_grid + + subroutine zone_save_basis_fields(self, path2linear) + class(zone_t), intent(in) :: self + character(len=*), intent(in) :: path2linear + character(len=1024) :: fname + integer :: unit, i, sol, comp + + write (fname, '(a,a,i0,a)') trim(path2linear), 'debug-data/zone_', self%index, '_basis.dat' + open (newunit=unit, file=trim(fname), status='replace', action='write') + + do i = 1, self%dim + write (unit, '(es24.16e3)', advance='no') self%r(i) + do sol = 1, self%Nwaves + do comp = 1, self%Ncomps + write (unit, '(a,es24.16e3,a,es24.16e3)', advance='no') & + char(9), real(self%basis(comp, sol, i), dp), char(9), aimag(self%basis(comp, sol, i)) + end do + end do + write (unit, *) + end do + + close (unit) + end subroutine zone_save_basis_fields + + subroutine zone_save_final_fields(self, path2linear) + class(zone_t), intent(in) :: self + character(len=*), intent(in) :: path2linear + character(len=1024) :: fname + integer :: unit, i, comp + + write (fname, '(a,a,i0,a)') trim(path2linear), 'zone_', self%index, '_EB.dat' + open (newunit=unit, file=trim(fname), status='replace', action='write') + + do i = 1, self%dim + write (unit, '(es24.16e3)', advance='no') self%r(i) + do comp = 1, self%Ncomps + write (unit, '(a,es24.16e3,a,es24.16e3)', advance='no') & + char(9), real(self%EB(comp, i), dp), char(9), aimag(self%EB(comp, i)) + end do + write (unit, *) + end do + + close (unit) + end subroutine zone_save_final_fields + + !> Registers a newly-allocated concrete zone (called by each subtype's + !> own *_zone_create_ factory) and returns its pool-index handle. + function zone_register(z) result(handle) + class(zone_t), pointer, intent(in) :: z + integer(c_intptr_t) :: handle + if (zone_pool_size >= max_zones) then + write (*, '(a)') 'error: zone_register: zone pool exhausted' + stop 1 + end if + zone_pool_size = zone_pool_size + 1 + zone_pool(zone_pool_size)%z => z + handle = int(zone_pool_size, c_intptr_t) + end function zone_register + + subroutine handle_to_zone(handle, z) + integer(c_intptr_t), value :: handle + class(zone_t), pointer, intent(out) :: z + z => zone_pool(int(handle))%z + end subroutine handle_to_zone + + !> ---- bind(C) dispatch shims for still-C++ callers (mode.cpp, + !> calc_mode.cpp, wave_code_interface.cpp) ---- + + subroutine zone_read_settings_c(handle, file) bind(C, name="zone_read_settings_") + integer(c_intptr_t), value :: handle + character(kind=c_char), intent(in) :: file(*) + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + call z%read_settings(c_string_to_fortran(file)) + end subroutine zone_read_settings_c + + subroutine zone_print_settings_c(handle) bind(C, name="zone_print_settings_") + integer(c_intptr_t), value :: handle + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + call z%print_settings() + end subroutine zone_print_settings_c + + subroutine zone_calc_basis_fields_c(handle, flag) bind(C, name="zone_calc_basis_fields_") + integer(c_intptr_t), value :: handle + integer(c_int), value :: flag + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + call z%calc_basis_fields(int(flag)) + end subroutine zone_calc_basis_fields_c + + subroutine zone_copy_E_and_B_fields_c(handle, EB_out) bind(C, name="zone_copy_E_and_B_fields_") + integer(c_intptr_t), value :: handle + real(c_double), intent(out) :: EB_out(*) + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + call z%copy_E_and_B_fields(EB_out) + end subroutine zone_copy_E_and_B_fields_c + + subroutine zone_calc_final_fields_c(handle) bind(C, name="zone_calc_final_fields_") + integer(c_intptr_t), value :: handle + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + call z%calc_final_fields() + end subroutine zone_calc_final_fields_c + + subroutine zone_calc_dispersion_c(handle) bind(C, name="zone_calc_dispersion_") + integer(c_intptr_t), value :: handle + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + call z%calc_dispersion() + end subroutine zone_calc_dispersion_c + + subroutine zone_save_dispersion_c(handle) bind(C, name="zone_save_dispersion_") + integer(c_intptr_t), value :: handle + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + call z%save_dispersion() + end subroutine zone_save_dispersion_c + + subroutine zone_calc_all_quants_c(handle) bind(C, name="zone_calc_all_quants_") + integer(c_intptr_t), value :: handle + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + call z%calc_all_quants() + end subroutine zone_calc_all_quants_c + + subroutine zone_save_all_quants_c(handle) bind(C, name="zone_save_all_quants_") + integer(c_intptr_t), value :: handle + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + call z%save_all_quants() + end subroutine zone_save_all_quants_c + + subroutine zone_eval_diss_power_density_c(handle, x, ttype, spec, dpd) & + bind(C, name="zone_eval_diss_power_density_") + integer(c_intptr_t), value :: handle + real(c_double), value :: x + integer(c_int), value :: ttype, spec + real(c_double), intent(out) :: dpd(*) + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + call z%eval_diss_power_density(x, int(ttype), int(spec), dpd) + end subroutine zone_eval_diss_power_density_c + + subroutine zone_eval_current_density_c(handle, x, ttype, spec, comp, J) & + bind(C, name="zone_eval_current_density_") + integer(c_intptr_t), value :: handle + real(c_double), value :: x + integer(c_int), value :: ttype, spec, comp + real(c_double), intent(out) :: J(*) + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + call z%eval_current_density(x, int(ttype), int(spec), int(comp), J) + end subroutine zone_eval_current_density_c + + real(c_double) function zone_get_r1_c(handle) bind(C, name="zone_get_r1_") result(res) + integer(c_intptr_t), value :: handle + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + res = z%get_r1() + end function zone_get_r1_c + + real(c_double) function zone_get_r2_c(handle) bind(C, name="zone_get_r2_") result(res) + integer(c_intptr_t), value :: handle + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + res = z%get_r2() + end function zone_get_r2_c + + integer(c_int) function zone_get_dim_of_basis_c(handle) bind(C, name="zone_get_dim_of_basis_") result(res) + integer(c_intptr_t), value :: handle + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + res = z%get_dim_of_basis() + end function zone_get_dim_of_basis_c + + integer(c_int) function zone_get_dim_of_basis_vector_c(handle) & + bind(C, name="zone_get_dim_of_basis_vector_") result(res) + integer(c_intptr_t), value :: handle + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + res = z%get_dim_of_basis_vector() + end function zone_get_dim_of_basis_vector_c + + integer(c_int) function zone_get_radial_grid_dimension_c(handle) & + bind(C, name="zone_get_radial_grid_dimension_") result(res) + integer(c_intptr_t), value :: handle + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + res = z%get_radial_grid_dimension() + end function zone_get_radial_grid_dimension_c + + integer(c_int) function zone_get_code_version_c(handle) bind(C, name="zone_get_code_version_") result(res) + integer(c_intptr_t), value :: handle + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + res = z%get_code_version() + end function zone_get_code_version_c + + integer(c_int) function zone_get_medium_c(handle) bind(C, name="zone_get_medium_") result(res) + integer(c_intptr_t), value :: handle + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + res = z%medium + end function zone_get_medium_c + + integer(c_int) function zone_get_bc1_c(handle) bind(C, name="zone_get_bc1_") result(res) + integer(c_intptr_t), value :: handle + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + res = z%bc1 + end function zone_get_bc1_c + + integer(c_int) function zone_get_bc2_c(handle) bind(C, name="zone_get_bc2_") result(res) + integer(c_intptr_t), value :: handle + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + res = z%bc2 + end function zone_get_bc2_c + + type(c_ptr) function zone_get_basis_at_left_boundary_c(handle) & + bind(C, name="zone_get_basis_at_left_boundary_") result(res) + integer(c_intptr_t), value :: handle + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + res = c_loc(z%basis(1, 1, 1)) + end function zone_get_basis_at_left_boundary_c + + type(c_ptr) function zone_get_basis_at_right_boundary_c(handle) & + bind(C, name="zone_get_basis_at_right_boundary_") result(res) + integer(c_intptr_t), value :: handle + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + res = c_loc(z%basis(1, 1, z%dim)) + end function zone_get_basis_at_right_boundary_c + + subroutine zone_save_basis_fields_c(handle, path2linear) bind(C, name="zone_save_basis_fields_") + integer(c_intptr_t), value :: handle + character(kind=c_char), intent(in) :: path2linear(*) + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + call z%save_basis_fields(c_string_to_fortran(path2linear)) + end subroutine zone_save_basis_fields_c + + subroutine zone_calc_superposition_of_basis_fields_c(handle, S_p) & + bind(C, name="zone_calc_superposition_of_basis_fields_") + integer(c_intptr_t), value :: handle + real(c_double), intent(in) :: S_p(*) + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + call z%calc_superposition_of_basis_fields(S_p(1:2*z%Nwaves)) + end subroutine zone_calc_superposition_of_basis_fields_c + + subroutine zone_save_final_fields_c(handle, path2linear) bind(C, name="zone_save_final_fields_") + integer(c_intptr_t), value :: handle + character(kind=c_char), intent(in) :: path2linear(*) + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + call z%save_final_fields(c_string_to_fortran(path2linear)) + end subroutine zone_save_final_fields_c + + subroutine zone_copy_radial_grid_c(handle, r_p) bind(C, name="zone_copy_radial_grid_") + integer(c_intptr_t), value :: handle + real(c_double), intent(out) :: r_p(*) + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + call z%copy_radial_grid(r_p) + end subroutine zone_copy_radial_grid_c + + subroutine zone_destroy_c(handle) bind(C, name="zone_destroy_") + integer(c_intptr_t), value :: handle + class(zone_t), pointer :: z + if (handle == 0_c_intptr_t) return + call handle_to_zone(handle, z) + deallocate (z) + nullify (zone_pool(int(handle))%z) + end subroutine zone_destroy_c + + !> Pre-existing names (zone.h), unchanged signatures: legacy stitching + !> Fortran already treats zone**/subclass** purely as an opaque handle. + subroutine get_right_boundary_of_zone(handle, rout) bind(C, name="get_right_boundary_of_zone_") + integer(c_intptr_t), intent(in) :: handle + real(c_double), intent(out) :: rout + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + rout = z%get_r2() + end subroutine get_right_boundary_of_zone + + subroutine get_left_boundary_of_zone(handle, rout) bind(C, name="get_left_boundary_of_zone_") + integer(c_intptr_t), intent(in) :: handle + real(c_double), intent(out) :: rout + class(zone_t), pointer :: z + call handle_to_zone(handle, z) + rout = z%get_r1() + end subroutine get_left_boundary_of_zone + + function c_string_to_fortran(cstr) result(fstr) + character(kind=c_char), intent(in) :: cstr(*) + character(len=:), allocatable :: fstr + integer :: i + i = 0 + do + if (cstr(i + 1) == c_null_char) exit + i = i + 1 + end do + allocate (character(len=i) :: fstr) + do i = 1, len(fstr) + fstr(i:i) = cstr(i) + end do + end function c_string_to_fortran + +end module kilca_zone_m diff --git a/KiLCA/post_processing/main_post_proc.cpp b/KiLCA/post_processing/main_post_proc.cpp deleted file mode 100644 index d389fec0..00000000 --- a/KiLCA/post_processing/main_post_proc.cpp +++ /dev/null @@ -1,634 +0,0 @@ -/*! \file - \brief The post processing program to evaluate form-factors in various variables (see input file). -*/ - -#include -#include -#include -#include -#include -#include - -#include "inout.h" -#include "constants.h" -#include "background.h" -#include "adaptive_grid_pol.h" - -/*******************************************************************/ - -extern "C" -{ -void save_form_facs_fortran_ (char *fname, int *modes_dim, int *modes_mn, int *m_min, int *m_max, - int *n_min, int *n_max, int *modes_index, - int *dim, double *sqr_psi_grid, double *ffpsi, int *format_flag); -} - -/*******************************************************************/ - -void transform_cyl_radius_to_surface_label (int dim, double * r, int pol_deg, - int label_flag, double * label); - -void transform_surface_label_to_cyl_radius (int dim, double * r, int pol_deg, - int label_flag, double * label); - -inline void evaluate_Br_formfactors (int dim1, double * r_EB1, double * prof_EB1, - int dim2, double * r_EB2, double * prof_EB2, - int pol_deg, double r, complex *form_facs); - -inline void evaluate_jp_over_Br (int dim_EB, double * r_EB, double * prof_EB, - int dim_jp, double * r_jp, double * prof_jp, - int pol_deg, double r, complex *form_facs); - -/*******************************************************************/ - -int main (int argc, char **argv) -{ -char name_out[][32] = {"Br_ff", "Jp_over_Br_over_r", "Tphi_ff"}; - -char name_label[][32] = {"cyl_radius", "sqrt_psi_pol", "psi_pol", "norm_psi_pol", "sqrt_psi_tor", "psi_tor", "norm_psi_tor"}; - -//read file: -char file_ff[] = "post_proc.in"; -FILE *in; - -if ((in=fopen (file_ff, "r"))==NULL) -{ - fprintf(stderr, "\nerror: post_proc: failed to open file %s\a\n", file_ff); - exit(0); -} - -char *str_buf = new char[1024]; //str buffer - -//configuration settings: -read_line_2skip_it (in, &str_buf); -char *conf = new char [1024]; -read_line_2get_string (in, &conf); - -char **path2projects = new char *[2]; - -path2projects[0] = new char[1024]; -read_line_2get_string (in, &(path2projects[0])); - -path2projects[1] = new char[1024]; -read_line_2get_string (in, &(path2projects[1])); - -read_line_2skip_it (in, &str_buf); - -//grid settings: -int dim; -double label_min, label_max, rmini; -read_line_2skip_it (in, &str_buf); -read_line_2get_int (in, &dim); -read_line_2get_double (in, &label_min); -read_line_2get_double (in, &label_max); -read_line_2get_double (in, &rmini); -read_line_2skip_it (in, &str_buf); - -//modes settings: -complex flab; -read_line_2skip_it (in, &str_buf); -read_line_2get_complex (in, &flab); - -int dma, imin, imax; -read_line_2get_int (in, &dma); -read_line_2get_int (in, &imin); -read_line_2get_int (in, &imax); - -int m_min, m_max, n_min, n_max; -read_line_2get_int (in, &m_min); -read_line_2get_int (in, &m_max); -read_line_2get_int (in, &n_min); -read_line_2get_int (in, &n_max); -read_line_2skip_it (in, &str_buf); - -int pol_deg; -read_line_2skip_it (in, &str_buf); -read_line_2get_int (in, &pol_deg); -read_line_2skip_it (in, &str_buf); - -int output_flag; -read_line_2skip_it (in, &str_buf); -read_line_2get_int (in, &output_flag); -read_line_2skip_it (in, &str_buf); - -int label_flag; -read_line_2skip_it (in, &str_buf); -read_line_2get_int (in, &label_flag); -read_line_2skip_it (in, &str_buf); - -int format_flag; -read_line_2skip_it (in, &str_buf); -read_line_2get_int (in, &format_flag); -read_line_2skip_it (in, &str_buf); - -fclose (in); - -//output label grid: -double * label = new double[dim]; for (int k=0; k *form_facs = new complex[(imax-imin+1)*dim]; - -int l; - -char *filename = new char[1024]; - -for (i=imin; i<=imax; i++) //over modes -{ - fprintf (stdout, "\n(m=%d, n=%d) mode...", modes[2*i], modes[2*i+1]); fflush(stdout); - - //EB is read always: - for (int p=0; p<2; p++) //over paths - { - //EB arrays: - sprintf (filename, "%slinear-data/m_%d_n_%d_flab_[%g,%g]/EB.dat", path2projects[p], modes[2*i], modes[2*i+1], real(flab), imag(flab)); - - dim_EB[p] = count_lines_in_file (filename, 0); - - r_EB[p] = new double[dim_EB[p]]; - prof_EB[p] = new double[ncols_EB*dim_EB[p]]; - - load_data_file (filename, dim_EB[p], ncols_EB, r_EB[p], prof_EB[p]); - } - - //current density: loads apropriate files - if (output_flag == 1) - { - int p = 0; //plasma path - - sprintf (filename,"%slinear-data/m_%d_n_%d_flab_[%g,%g]/zone_0_current_dens_p_0_t_lab.dat", path2projects[p], modes[2*i], modes[2*i+1], real(flab), imag(flab)); - - dim_jp[p] = count_lines_in_file (filename, 0); - - r_jp[p] = new double[dim_jp[p]]; - prof_jp[p] = new double[ncols_jp*dim_jp[p]]; - - load_data_file (filename, dim_jp[p], ncols_jp, r_jp[p], prof_jp[p]); - } - - //torques: loads apropriate files - if (output_flag == 2) - { - - } - - //interpolation: - for (int k=0; krmini) break; - - for (int k=0; k *form_facs) -{ -complex Q[2]; - -double re_Q, im_Q; - -int re_Br_ind = 7-1; //index starts from zero -int im_Br_ind = 8-1; //index starts from zero - -static int ind1 = dim1/2; find_index_for_interp (pol_deg, r, dim1, r_EB1, &ind1); - -eval_neville_polynom (r_EB1+ind1, prof_EB1+dim1*re_Br_ind+ind1, 1, pol_deg, r, &re_Q); -eval_neville_polynom (r_EB1+ind1, prof_EB1+dim1*im_Br_ind+ind1, 1, pol_deg, r, &im_Q); - -Q[0] = re_Q + I*im_Q; //Br - -static int ind2 = dim2/2; find_index_for_interp (pol_deg, r, dim2, r_EB2, &ind2); - -eval_neville_polynom (r_EB2+ind2, prof_EB2+dim2*re_Br_ind+ind2, 1, pol_deg, r, &re_Q); -eval_neville_polynom (r_EB2+ind2, prof_EB2+dim2*im_Br_ind+ind2, 1, pol_deg, r, &im_Q); - -Q[1] = re_Q + I*im_Q; //Br - -//*form_facs = Q[0]; -*form_facs = Q[0]/Q[1]; -} - -/*****************************************************************************/ - -inline void evaluate_jp_over_Br (int dim_EB, double * r_EB, double * prof_EB, - int dim_jp, double * r_jp, double * prof_jp, - int pol_deg, double r, complex *form_facs) -{ -complex Q[2]; - -double re_Q, im_Q; - -int re_Br_ind = 7-1; //index starts from zero -int im_Br_ind = 8-1; //index starts from zero - -static int ind1 = dim_EB/2; find_index_for_interp (pol_deg, r, dim_EB, r_EB, &ind1); - -eval_neville_polynom (r_EB+ind1, prof_EB+dim_EB*re_Br_ind+ind1, 1, pol_deg, r, &re_Q); -eval_neville_polynom (r_EB+ind1, prof_EB+dim_EB*im_Br_ind+ind1, 1, pol_deg, r, &im_Q); - -Q[0] = re_Q + I*im_Q; //Br - -int re_jp_ind = 0; //index starts from zero -int im_jp_ind = 1; //index starts from zero - -static int ind2 = dim_jp/2; find_index_for_interp (pol_deg, r, dim_jp, r_jp, &ind2); - -eval_neville_polynom (r_jp+ind2, prof_jp+dim_jp*re_jp_ind+ind2, 1, pol_deg, r, &re_Q); -eval_neville_polynom (r_jp+ind2, prof_jp+dim_jp*im_jp_ind+ind2, 1, pol_deg, r, &im_Q); - -Q[1] = re_Q + I*im_Q; //jp - -//*form_facs = Q[1]; -//*form_facs = Q[1]/Q[0]; -*form_facs = Q[1]/Q[0]/r; -} - -/*****************************************************************************/ diff --git a/KiLCA/post_processing/main_post_proc.f90 b/KiLCA/post_processing/main_post_proc.f90 new file mode 100644 index 00000000..17a6fdef --- /dev/null +++ b/KiLCA/post_processing/main_post_proc.f90 @@ -0,0 +1,526 @@ +!> Post-processing program to evaluate form-factors in various radial variables, +!> ported from post_processing/main_post_proc.cpp. Reads post_proc.in and +!> modes.in, loads the per-mode EB.dat (and, for the current-density output, the +!> zone_0_current_dens files) written by a prior KiLCA run, interpolates the +!> requested form-factor onto a surface-label grid, writes the human-readable +!> "..