├── .gitignore ├── .travis.yml ├── CMakeLists.txt ├── License.txt ├── Manual ├── AAA_INSTALL_DISCUS_CYGWIN.pdf ├── AAA_INSTALL_DISCUS_LINUX.pdf ├── AAA_INSTALL_DISCUS_MACOS.pdf ├── AAA_INSTALL_DISCUS_WINDOWS_WSL.pdf ├── diffev_man.pdf ├── discus_man.pdf ├── kuplot_man.pdf ├── mixscat_man.pdf ├── package_man.pdf ├── refine_man.pdf └── suite_man.pdf ├── README.md ├── cmake ├── DefaultSearchPaths.cmake ├── FindCython.cmake ├── FindF2PY.cmake ├── FindFFTW.cmake ├── FindFINUFFT.cmake ├── FindNEXUS.cmake ├── FindNumPy.cmake ├── FindPGPLOT.cmake ├── FindPythonExtensions.cmake ├── FindReadline.cmake ├── LICENSE_FFTW.txt ├── UseCython.cmake ├── UseF2PY.cmake ├── UseF2Py.cmake.orig ├── UsePythonExtensions.cmake └── targetLinkLibrariesWithDynamicLookup.cmake ├── diffev ├── examples │ ├── arctan │ │ ├── DATA │ │ │ ├── data.noisy │ │ │ ├── data.values │ │ │ ├── data.values.250 │ │ │ └── makedata.mac │ │ ├── README │ │ ├── REPEAT │ │ ├── arctan.f │ │ ├── arctan.mac │ │ ├── clean │ │ ├── diffev.mac │ │ ├── diffev_continue.mac │ │ ├── diffev_setup.mac │ │ ├── fit.mac │ │ ├── kcompare.mac │ │ ├── kdraw.mac │ │ ├── kpar_par.mac │ │ ├── kpar_par_90.mac │ │ ├── kpara.mac │ │ ├── kpara_90.mac │ │ ├── krval_par.mac │ │ ├── kuplot.mac │ │ ├── loop.mac │ │ ├── main.mac │ │ ├── second.mac │ │ └── wdiffev.mac │ └── parabola │ │ ├── DATA │ │ └── funktion.data │ │ ├── cleanup.mac │ │ ├── diffev.mac │ │ ├── diffev_increase.mac │ │ ├── diffev_increase_cube.mac │ │ ├── diffev_run.mac │ │ ├── diffev_setup.mac │ │ ├── function │ │ ├── function.f90 │ │ ├── kpar_par.mac │ │ ├── kpara.mac │ │ ├── ksingle.mac │ │ ├── kup.backup.mac │ │ ├── kup.select.mac │ │ ├── kup_diffev.mac │ │ └── make_func.mac └── prog │ ├── CMakeLists.txt │ ├── appl_dif.hlp │ ├── compare.f90 │ ├── constraint.f90 │ ├── create_trial.f90 │ ├── diff_evol.f90 │ ├── diffev.f90 │ ├── diffev_add_param.f90 │ ├── diffev_allocate_appl.f90 │ ├── diffev_blk_appl.f90 │ ├── diffev_branch.f90 │ ├── diffev_config.f90 │ ├── diffev_distrib_mod.f90 │ ├── diffev_do_exit.f90 │ ├── diffev_err_appl.f90 │ ├── diffev_execute_cost.f90 │ ├── diffev_kdo.f90 │ ├── diffev_loop.f90 │ ├── diffev_loop_mpi.f90 │ ├── diffev_py.f90 │ ├── diffev_random.f90 │ ├── diffev_refine.f90 │ ├── diffev_release.f90 │ ├── diffev_reset.f90 │ ├── diffev_set_cost.f90 │ ├── diffev_set_gen.f90 │ ├── diffev_set_sub.f90 │ ├── diffev_setup.f90 │ ├── diffev_show.f90 │ ├── diffev_upd_par.f90 │ ├── initialise.f90 │ ├── no_mpi.f90 │ ├── population.f90 │ ├── run_mpi_mod.f90 │ ├── support_diffev_mod.f90 │ ├── sysmac │ ├── modify_trial.mac │ └── systest.mac │ ├── triple_perm.f90 │ └── with_mpi.f90 ├── discus └── prog │ ├── CMakeLists.txt │ ├── appl_dis.hlp │ ├── atom_env_mod.f90 │ ├── atom_line.f90 │ ├── atom_name.f90 │ ├── bv_data_mod.f90 │ ├── celltoindex.f90 │ ├── check_blen_mod.f90 │ ├── check_bound_mod.f90 │ ├── check_user_prop_mod.f90 │ ├── chem.f90 │ ├── chem_aver_mod.f90 │ ├── chem_mod.f90 │ ├── chem_multi.f90 │ ├── chem_neig_multi.f90 │ ├── chem_symm_mod.f90 │ ├── class_atom.f90 │ ├── class_crystal.f90 │ ├── class_dc_def.f90 │ ├── class_internal.f90 │ ├── color.map │ ├── conn_def_mod.f90 │ ├── conn_mod.f90 │ ├── conn_sup_mod.f90 │ ├── conn_type_mod.f90 │ ├── crystal_mod.f90 │ ├── debye_mod.f90 │ ├── deco_mod.f90 │ ├── demolec.f90 │ ├── demolec_mod.f90 │ ├── diffuse_mod.f90 │ ├── discus.f90 │ ├── discus_3dpdf.f90 │ ├── discus_allocate_appl_mod.f90 │ ├── discus_blk_appl.f90 │ ├── discus_bragg.f90 │ ├── discus_branch.f90 │ ├── discus_build_molecule.f90 │ ├── discus_config_mod.f90 │ ├── discus_crystal.f90 │ ├── discus_discamb.f90 │ ├── discus_err_appl.f90 │ ├── discus_estimate.f90 │ ├── discus_exit.f90 │ ├── discus_exp2pdf.f90 │ ├── discus_exp2pdf_data.f90 │ ├── discus_exp2pdf_load.f90 │ ├── discus_exp2pdf_run.f90 │ ├── discus_exp2pdf_supp.f90 │ ├── discus_export.f90 │ ├── discus_fft.f90 │ ├── discus_fit.f90 │ ├── discus_guess_atoms.f90 │ ├── discus_kdo.f90 │ ├── discus_kdo_common.f90 │ ├── discus_loop.f90 │ ├── discus_mrc.f90 │ ├── discus_nexus.f90 │ ├── discus_nexus_no.f90 │ ├── discus_nipl_header.f90 │ ├── discus_out_file.f90 │ ├── discus_pdf_file.f90 │ ├── discus_plot.f90 │ ├── discus_plot_export.f90 │ ├── discus_plot_init.f90 │ ├── discus_plot_mod.f90 │ ├── discus_pointgrp.f90 │ ├── discus_powder_fft.f90 │ ├── discus_powder_file.f90 │ ├── discus_prep_anis.f90 │ ├── discus_prepare_refine.f90 │ ├── discus_py.f90 │ ├── discus_reduce.f90 │ ├── discus_reset_all.f90 │ ├── discus_s_out_file.f90 │ ├── discus_s_pdf_file.f90 │ ├── discus_s_powder_file.f90 │ ├── discus_save.f90 │ ├── discus_save_mod.f90 │ ├── discus_save_temp.f90 │ ├── discus_set_sub.f90 │ ├── discus_setup.f90 │ ├── discus_show.f90 │ ├── discus_super_func.f90 │ ├── discus_super_mod.f90 │ ├── discus_super_waves.f90 │ ├── discus_symmetrize.f90 │ ├── discus_trans_to_short.f90 │ ├── discus_upd_par.f90 │ ├── discus_xplor.f90 │ ├── do_find_mod.f90 │ ├── domain.f90 │ ├── domain_irreg_mod.f90 │ ├── domain_mod.f90 │ ├── domaindis_mod.f90 │ ├── external.f90 │ ├── external_mod.f90 │ ├── extrmc.f90 │ ├── find_top.f90 │ ├── four_angles_mod.f90 │ ├── four_strucf_OMP_mod.f90 │ ├── four_strucf_cuda.cu │ ├── four_strucf_cuda_mod.f90 │ ├── four_strucf_mod.f90 │ ├── fourier.f90 │ ├── fourier_conv.f90 │ ├── fourier_finufft.f90 │ ├── fourier_form.f90 │ ├── fourier_lmn_mod.f90 │ ├── fourier_reset.f90 │ ├── fourier_sup.f90 │ ├── gen_add_mod.f90 │ ├── generate_mod.f90 │ ├── get_iscat_mod.f90 │ ├── graphic.f90 │ ├── hdf_write.f90 │ ├── hdf_write_no.f90 │ ├── insert.f90 │ ├── insert_mod.f90 │ ├── intens_mod.f90 │ ├── inter_readstru.f90 │ ├── interpret.f90 │ ├── inverse_mod.f90 │ ├── mc_mod.f90 │ ├── metric.f90 │ ├── micro_mod.f90 │ ├── mmc.f90 │ ├── mmc_basic.f90 │ ├── mmc_mod.f90 │ ├── mmc_mole.f90 │ ├── modify_func_mod.f90 │ ├── modify_mod.f90 │ ├── mole_env_mod.f90 │ ├── molecule_alloc.f90 │ ├── molecule_func.f90 │ ├── molecule_mod.f90 │ ├── output_mod.f90 │ ├── patters.f90 │ ├── patters_mod.f90 │ ├── pdf.f90 │ ├── pdf_mod.f90 │ ├── perioditize.f90 │ ├── phases_mod.f90 │ ├── phases_set_form.f90 │ ├── phases_set_mod.f90 │ ├── phases_stack.f90 │ ├── place_molecule.f90 │ ├── pname.inc │ ├── powder.f90 │ ├── powder_mod.f90 │ ├── powder_out_partial.f90 │ ├── powder_pdf_hist.f90 │ ├── powder_scat_mod.f90 │ ├── powder_tables.f90 │ ├── powder_write_mod.f90 │ ├── private.f90 │ ├── prop_char_mod.f90 │ ├── prop_para_func.f90 │ ├── prop_para_mod.f90 │ ├── quad.f90 │ ├── qval.f90 │ ├── read_internal_mod.f90 │ ├── recipro_mod.f90 │ ├── refine_mod.f90 │ ├── rmc.f90 │ ├── rmc_mod.f90 │ ├── rmc_sup_mod.f90 │ ├── rmc_symm.f90 │ ├── shear.f90 │ ├── shear_mod.f90 │ ├── spcgr_apply.f90 │ ├── spcgr_mod.f90 │ ├── spcgr_setup.f90 │ ├── stack.f90 │ ├── stack_cr_mod.f90 │ ├── stack_mod.f90 │ ├── stack_rese.f90 │ ├── storage.f90 │ ├── structur.f90 │ ├── surface_func_mod.f90 │ ├── surface_mod.f90 │ ├── sym_add_mod.f90 │ ├── symm.f90 │ ├── symm_mod.f90 │ ├── symm_sup.f90 │ ├── sysmac │ └── systest.mac │ ├── tensors.f90 │ ├── thermal.f90 │ ├── trafo.f90 │ ├── trans_cart_mod.f90 │ ├── trans_sup.f90 │ ├── transfrm.f90 │ ├── transfrm_mod.f90 │ ├── unitcell_mod.f90 │ ├── update_cr_dim.f90 │ ├── utilities.f90 │ ├── vtk_mod.f90 │ ├── waves.f90 │ ├── waves_mod.f90 │ ├── wyckoff_mod.f90 │ └── zone.f90 ├── experi └── prog │ ├── CMakeLists.txt │ ├── appl_exp.hlp │ ├── experi_kdo.f90 │ ├── experi_loop.f90 │ ├── experi_reset.f90 │ ├── experi_setup.f90 │ └── experi_setup_sub.f90 ├── finufft ├── AAA.README ├── CMakeLists.txt ├── LICENSE ├── contrib │ ├── legendre_rule_fast.cpp │ ├── legendre_rule_fast.h │ ├── legendre_rule_fast.license │ └── legendre_rule_fast.o ├── fortran │ ├── README │ ├── cmcl_license.txt │ └── finufftfort.cpp ├── include │ ├── finufft.fh │ ├── finufft.h │ ├── finufft │ │ ├── defs.h │ │ ├── dirft.h │ │ ├── fft.h │ │ ├── fftw_defs.h │ │ ├── finufft_eitherprec.h │ │ ├── spreadinterp.h │ │ ├── test_defs.h │ │ ├── utils.h │ │ └── utils_precindep.h │ ├── finufft_eitherprec.h │ ├── finufft_errors.h │ ├── finufft_mod.f90 │ ├── finufft_opts.h │ └── finufft_spread_opts.h └── src │ ├── fft.cpp │ ├── finufft.cpp │ ├── ker_horner_allw_loop.c │ ├── ker_horner_allw_loop_constexpr.h │ ├── ker_lowupsampfac_horner_allw_loop.c │ ├── ker_lowupsampfac_horner_allw_loop_constexpr.h │ ├── simpleinterfaces.cpp │ ├── spreadinterp.cpp │ ├── utils.cpp │ └── utils_precindep.cpp ├── kuplot └── prog │ ├── CMakeLists.txt │ ├── appl_kup.dic │ ├── appl_kup.hlp │ ├── calc.f90 │ ├── color.f90 │ ├── color.map │ ├── draw.f90 │ ├── fit.f90 │ ├── fit_mache_kdo.f90 │ ├── fit_macro.f90 │ ├── fit_params_mod.f90 │ ├── fit_set_sub_mod.f90 │ ├── fit_top.f90 │ ├── frame.f90 │ ├── gsas.f90 │ ├── init_win.f90 │ ├── init_x11.f90 │ ├── koordinate_mod.f90 │ ├── kuplot.f90 │ ├── kuplot_2dmap.f90 │ ├── kuplot_2dmap_mod.f90 │ ├── kuplot_3dmap.f90 │ ├── kuplot_3dmap_draw.f90 │ ├── kuplot_3dmap_mod.f90 │ ├── kuplot_adt.f90 │ ├── kuplot_blk_appl.f90 │ ├── kuplot_branch.f90 │ ├── kuplot_config.f90 │ ├── kuplot_diffev_plot.f90 │ ├── kuplot_draw_low.f90 │ ├── kuplot_draw_tframe.f90 │ ├── kuplot_err_appl.f90 │ ├── kuplot_exit.f90 │ ├── kuplot_extrema.f90 │ ├── kuplot_global.f90 │ ├── kuplot_kdo.f90 │ ├── kuplot_kdo_common.f90 │ ├── kuplot_load_h5.f90 │ ├── kuplot_load_h5_no.f90 │ ├── kuplot_load_shelx.f90 │ ├── kuplot_loop.f90 │ ├── kuplot_low.f90 │ ├── kuplot_mod.f90 │ ├── kuplot_nexus.f90 │ ├── kuplot_nonexus.f90 │ ├── kuplot_place.f90 │ ├── kuplot_plot.f90 │ ├── kuplot_plot_low.f90 │ ├── kuplot_py.f90 │ ├── kuplot_reset.f90 │ ├── kuplot_save.f90 │ ├── kuplot_setup.f90 │ ├── kuplot_setup_sub.f90 │ ├── kuplot_show.f90 │ ├── kuplot_toglobal.f90 │ ├── kuplot_top.f90 │ ├── kuplot_upd_par.f90 │ ├── kuplot_wichtung.f90 │ ├── kuplot_words_mod.f90 │ ├── load.f90 │ ├── math.f90 │ ├── nexus.inc │ ├── para.f90 │ └── sysmac │ ├── gs-sub.mac │ └── systest.mac ├── lib_f90 ├── CMakeLists.txt ├── FCreadline.c ├── allocate_generic.f90 ├── appl_unix.f90 ├── arrays_mod.f90 ├── ber_params_mod.f90 ├── berechne_mod.f90 ├── blanks_mod.f90 ├── blockdat.f90 ├── build_name_mod.f90 ├── calc_expr_mod.f90 ├── calc_intr_mod.f90 ├── charact_mod.f90 ├── class_macro.f90 ├── cmdline_args_mod.f90 ├── constants_mod.f90 ├── count_col_mod.f90 ├── csocket.c ├── csup.c ├── data_struc.f90 ├── data_struc_type.f90 ├── data_types.f90 ├── date.inc.template ├── debug.h ├── debug_mod.f90 ├── define_variable_mod.f90 ├── dkdo.f90 ├── do_echo_mod.f90 ├── do_eval_mod.f90 ├── do_execute_mod.f90 ├── do_read_number_mod.f90 ├── do_replace_expr.f90 ├── do_set_mod.f90 ├── do_show_mod.f90 ├── do_string_alloc_mod.f90 ├── do_variable_mod.f90 ├── do_wait_mod.f90 ├── doact_mod.f90 ├── doexec_mod.f90 ├── doloop_mod.f90 ├── dummy_loop_mpi.f90 ├── edit.c ├── element_data_mod.f90 ├── envir_mod.f90 ├── errlist.f90 ├── errlist_mod.f90 ├── ersetz_mod.f90 ├── ersetzl_mod.f90 ├── exit_mod.f90 ├── exit_para.f90 ├── fast_fourier_mod.f90 ├── fft_singleton.f90 ├── fftpack6.0.f90 ├── forpy_mod.F90 ├── fput_mod.f90 ├── gamma_mod.f90 ├── gauss_lorentz_pseudo.f90 ├── gaussj_mod.f90 ├── gen_mpi_mod.f90 ├── get_params_mod.f90 ├── global_data.f90 ├── hdf5_def.f90 ├── hdf5_params.f90 ├── hdf5_params_no.f90 ├── hdf5_read.f90 ├── hdf_write.f90 ├── hdf_write_no.f90 ├── help.f90 ├── jsu_readline.f90 ├── kdo_all_mod.f90 ├── learn.f90 ├── learn_mod.f90 ├── length_string_mod.f90 ├── lib_conv.f90 ├── lib_conver_shelx.f90 ├── lib_element_status.f90 ├── lib_f90.hlp ├── lib_f90_alloc.f90 ├── lib_f90_config.f90 ├── lib_f90_default.f90 ├── lib_f90_fftw3.f90 ├── lib_f90_profile.f90 ├── lib_forpython.f90 ├── lib_functions.f90 ├── lib_get_var_type.f90 ├── lib_global_flags.f90 ├── lib_ik.f90 ├── lib_lanczos.f90 ├── lib_load.f90 ├── lib_math.f90 ├── lib_metric.f90 ├── lib_nx_read.f90 ├── lib_nx_transfer_mod.f90 ├── lib_nx_write.f90 ├── lib_timer.f90 ├── lib_timer_mod.f90 ├── lib_trans.f90 ├── lib_upd_mod.f90 ├── lib_use_coor.f90 ├── lib_weights.f90 ├── lib_write_debug.f90 ├── macro.f90 ├── macro_internal.f90 ├── macro_mod.f90 ├── map_1dtofield.f90 ├── math_sup.f90 ├── matrix_mod.f90 ├── memory.f90 ├── mpi_slave_mod.f90 ├── mrc_data.f90 ├── op_linux.f90 ├── op_macos.f90 ├── op_windows.f90 ├── operating_mod.f90 ├── parallel_CUDA.f90 ├── parallel_mod.f90 ├── parallel_none.f90 ├── param_mod.f90 ├── precision_command_mod.f90 ├── precision_mod.f90 ├── profile_tof.f90 ├── prompt_mod.f90 ├── random.f90 ├── random_mod.f90 ├── random_state_mod.f90 ├── refine_params.f90 ├── remote.f90 ├── reserved_mod.f90 ├── search_string_mod.f90 ├── send_get.f90 ├── set_sub_generic_mod.f90 ├── sine_table.f90 ├── sockets_mod.f90 ├── sorting.f90 ├── spline_mod.f90 ├── str_comp_mod.f90 ├── string_convert_mod.f90 ├── string_extract_mod.f90 ├── sup.f90 ├── support_mod.f90 ├── sys_gfortran.f90 ├── sys_intel.f90 ├── sys_mac.f90 ├── sys_pgi.f90 ├── take_param_mod.f90 ├── terminal_mod.f90 ├── times_mod.f90 ├── trig_degree_mod.f90 ├── variable_array_calc.f90 ├── variable_mod.f90 ├── variable_test.f90 ├── version.inc.template ├── win32-glob.c ├── win32-glob.h └── wink_mod.f90 ├── mixscat ├── examples │ ├── CeCe.res │ ├── CeCe_new_diff.gr │ ├── CeF.res │ ├── CeF3_Bulk_npdf_03902.gr │ ├── CeF3_bulk_binned.gr │ ├── CeF3_fake_N.gr │ ├── CeF3_fake_X.gr │ ├── CeF3_structure.cif │ ├── CeF_new_diff.gr │ ├── FF_new_diff.gr │ ├── cece.gr │ ├── cece.ma │ ├── cef.gr │ ├── cef.ma │ ├── cef3.cll │ ├── fake.mac │ ├── ff.gr │ ├── ff.ma │ ├── ff.res │ ├── p.mac │ ├── pdf.mac │ ├── pma.mac │ ├── test.mac │ ├── tot.gr │ ├── w_CeCe.mac │ ├── w_CeF.mac │ ├── w_FF.mac │ ├── wn_CeCe.mac │ ├── wn_CeF.mac │ └── wn_FF.mac └── prog │ ├── CMakeLists.txt │ ├── appl_mix.hlp │ ├── blk_appl.f90 │ ├── config_mod.f90 │ ├── err_appl.f90 │ ├── exit.f90 │ ├── fit.f90 │ ├── kdo.f90 │ ├── lazy.f │ ├── load.f90 │ ├── mixscat.f90 │ ├── mixscat_mod.f90 │ ├── save.f90 │ ├── set.f90 │ ├── show.f90 │ ├── sysmac │ └── systest.mac │ ├── upd_par.f90 │ └── weights.f90 ├── nexus ├── NXUmodule.f90 └── NXmodule.f90 ├── python ├── CMakeLists.txt ├── Notebooks │ ├── APITests.ipynb │ ├── PowderPlotting.ipynb │ ├── demo.mac │ ├── one.mac │ ├── plot3d.mac │ ├── pow.py │ ├── powder.mac │ ├── primitive.cell │ ├── test.py │ ├── two.mac │ └── vartest.mac └── suite_python.f90 ├── refine └── prog │ ├── CMakeLists.txt │ ├── appl_ref.hlp │ ├── refine_add_param.f90 │ ├── refine_allocate_appl.f90 │ ├── refine_blk_appl.f90 │ ├── refine_branch.f90 │ ├── refine_constraint.f90 │ ├── refine_control.f90 │ ├── refine_current.f90 │ ├── refine_data_mod.f90 │ ├── refine_do_exit.f90 │ ├── refine_err_appl.f90 │ ├── refine_fit_erg.f90 │ ├── refine_fit_mache_kdo.f90 │ ├── refine_fit_set_sub_mod.f90 │ ├── refine_fix.f90 │ ├── refine_head_mod.f90 │ ├── refine_kdo.f90 │ ├── refine_load.f90 │ ├── refine_log_mod.f90 │ ├── refine_loop.f90 │ ├── refine_loop_mpi.f90 │ ├── refine_mac_mod.f90 │ ├── refine_params.f90 │ ├── refine_random_mod.f90 │ ├── refine_reset.f90 │ ├── refine_run.f90 │ ├── refine_run_mpi_mod.f90 │ ├── refine_set.f90 │ ├── refine_set_param.f90 │ ├── refine_setup.f90 │ ├── refine_setup_sub.f90 │ ├── refine_show.f90 │ ├── refine_upd_par.f90 │ └── sysmac │ └── systest.mac ├── release_notes.txt ├── scripts ├── MACconfig.sh └── setup.sh ├── suite └── prog │ ├── CMakeLists.txt │ ├── appl_suite.hlp │ ├── suite.f90 │ ├── suite_branch.f90 │ ├── suite_err_appl.f90 │ ├── suite_execute_cost.f90 │ ├── suite_exit.f90 │ ├── suite_init_mod.f90 │ ├── suite_kdo.f90 │ ├── suite_loop.f90 │ ├── suite_out_file.f90 │ ├── suite_parallel.f90 │ ├── suite_pdf_file.f90 │ ├── suite_powder_file.f90 │ ├── suite_set_sub_mod.f90 │ ├── suite_setup_mod.f90 │ ├── suite_top.f90 │ ├── suite_upd_par.f90 │ └── sysmac │ └── systest.mac └── tools ├── convert2f90 ├── convert_inc2f90 ├── create_dependency_list ├── make_dep ├── make_dep.f90 ├── makedep.pl ├── substitute_end_inc ├── substitute_inc └── substitute_keywords /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | Makefile 3 | date.inc 4 | cmake_install.cmake 5 | CMakeFiles 6 | BACK* 7 | Doxygen* 8 | .ipynb_checkpoints/ 9 | python/.ipynb_checkpoints/ 10 | private.f90 11 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | 3 | compiler: gcc 4 | 5 | before_install: 6 | - sudo apt-get install -qq gfortran pgplot5 7 | 8 | before_script: 9 | - cmake . 10 | 11 | script: 12 | - make 13 | -------------------------------------------------------------------------------- /License.txt: -------------------------------------------------------------------------------- 1 | The DISCUS software is provided without warranty of any kind. No liability is taken for any loss or damages, direct or indirect, that may result through the use of the DISCUS package. No warranty is made with respect to this manual, or the program and functions therein. There are no warranties that the programs are free of error, or that they are consistent with any standard, or that they will meet the requirement for a particular application. 2 | 3 | The programs and the manual have been thoroughly checked. Nevertheless, it can not be guaranteed that the manual is correct and up-to-date in every detail. The manuals and programs may be changed without notice. 4 | 5 | The DISCUS package is intended as a public domain program. It may be used free of charge. Any commercial use is, however, not allowed without the explicit written permission of the authors. 6 | -------------------------------------------------------------------------------- /Manual/AAA_INSTALL_DISCUS_CYGWIN.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tproffen/DiffuseCode/cafd7934ec4e96d3feadafb99c8d0ecce43de3c1/Manual/AAA_INSTALL_DISCUS_CYGWIN.pdf -------------------------------------------------------------------------------- /Manual/AAA_INSTALL_DISCUS_LINUX.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tproffen/DiffuseCode/cafd7934ec4e96d3feadafb99c8d0ecce43de3c1/Manual/AAA_INSTALL_DISCUS_LINUX.pdf -------------------------------------------------------------------------------- /Manual/AAA_INSTALL_DISCUS_MACOS.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tproffen/DiffuseCode/cafd7934ec4e96d3feadafb99c8d0ecce43de3c1/Manual/AAA_INSTALL_DISCUS_MACOS.pdf -------------------------------------------------------------------------------- /Manual/AAA_INSTALL_DISCUS_WINDOWS_WSL.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tproffen/DiffuseCode/cafd7934ec4e96d3feadafb99c8d0ecce43de3c1/Manual/AAA_INSTALL_DISCUS_WINDOWS_WSL.pdf -------------------------------------------------------------------------------- /Manual/diffev_man.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tproffen/DiffuseCode/cafd7934ec4e96d3feadafb99c8d0ecce43de3c1/Manual/diffev_man.pdf -------------------------------------------------------------------------------- /Manual/discus_man.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tproffen/DiffuseCode/cafd7934ec4e96d3feadafb99c8d0ecce43de3c1/Manual/discus_man.pdf -------------------------------------------------------------------------------- /Manual/kuplot_man.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tproffen/DiffuseCode/cafd7934ec4e96d3feadafb99c8d0ecce43de3c1/Manual/kuplot_man.pdf -------------------------------------------------------------------------------- /Manual/mixscat_man.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tproffen/DiffuseCode/cafd7934ec4e96d3feadafb99c8d0ecce43de3c1/Manual/mixscat_man.pdf -------------------------------------------------------------------------------- /Manual/package_man.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tproffen/DiffuseCode/cafd7934ec4e96d3feadafb99c8d0ecce43de3c1/Manual/package_man.pdf -------------------------------------------------------------------------------- /Manual/refine_man.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tproffen/DiffuseCode/cafd7934ec4e96d3feadafb99c8d0ecce43de3c1/Manual/refine_man.pdf -------------------------------------------------------------------------------- /Manual/suite_man.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tproffen/DiffuseCode/cafd7934ec4e96d3feadafb99c8d0ecce43de3c1/Manual/suite_man.pdf -------------------------------------------------------------------------------- /cmake/FindReadline.cmake: -------------------------------------------------------------------------------- 1 | # from http://websvn.kde.org/trunk/KDE/kdeedu/cmake/modules/FindReadline.cmake 2 | # http://websvn.kde.org/trunk/KDE/kdeedu/cmake/modules/COPYING-CMAKE-SCRIPTS 3 | # --> BSD licensed 4 | # 5 | # GNU Readline library finder 6 | if(READLINE_INCLUDE_DIR AND READLINE_LIBRARY AND NCURSES_LIBRARY) 7 | set(READLINE_FOUND TRUE) 8 | else(READLINE_INCLUDE_DIR AND READLINE_LIBRARY AND NCURSES_LIBRARY) 9 | FIND_PATH(READLINE_INCLUDE_DIR readline/readline.h 10 | /usr/include/readline 11 | ) 12 | 13 | # 2008-04-22 The next clause used to read like this: 14 | # 15 | # FIND_LIBRARY(READLINE_LIBRARY NAMES readline) 16 | # FIND_LIBRARY(NCURSES_LIBRARY NAMES ncurses ) 17 | # include(FindPackageHandleStandardArgs) 18 | # FIND_PACKAGE_HANDLE_STANDARD_ARGS(Readline DEFAULT_MSG NCURSES_LIBRARY READLINE_INCLUDE_DIR READLINE_LIBRARY ) 19 | # 20 | # I was advised to modify it such that it will find an ncurses library if 21 | # required, but not if one was explicitly given, that is, it allows the 22 | # default to be overridden. PH 23 | 24 | FIND_LIBRARY(READLINE_LIBRARY NAMES readline) 25 | include(FindPackageHandleStandardArgs) 26 | FIND_PACKAGE_HANDLE_STANDARD_ARGS(Readline DEFAULT_MSG READLINE_INCLUDE_DIR READLINE_LIBRARY ) 27 | 28 | MARK_AS_ADVANCED(READLINE_INCLUDE_DIR READLINE_LIBRARY) 29 | endif(READLINE_INCLUDE_DIR AND READLINE_LIBRARY AND NCURSES_LIBRARY) 30 | 31 | 32 | -------------------------------------------------------------------------------- /cmake/LICENSE_FFTW.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Wenzel Jakob; 2017, Patrick Bos 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | * Neither the name of the copyright holder nor the names of its 15 | contributors may be used to endorse or promote products derived from 16 | this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 19 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 22 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 24 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 25 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 26 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 27 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /diffev/examples/arctan/DATA/makedata.mac: -------------------------------------------------------------------------------- 1 | rese 2 | func 100.*(atan((abs(r[0]-100.23))/0.1)), -50,150,0.10 3 | skal 4 | mark 50 5 | plot 6 | -------------------------------------------------------------------------------- /diffev/examples/arctan/README: -------------------------------------------------------------------------------- 1 | This is an example for the refinement of a difficult function. 2 | 3 | LINUX / MAC 4 | Compile the program "arctan.f" which calculates the function 5 | and then start diffev and execute the macro diffev.mac. 6 | 7 | WINDOWS 8 | Start diffev and execute the macro wdiffev.mac 9 | # 10 | ################################################################################# 11 | # 12 | 13 | While this runs, you can use the kuplot macros to observe the progress of 14 | the refinement: 15 | 16 | kpara.mac Shows how the r-value or a parameter changes through the 17 | generations 18 | kdraw.mac Plots the observed and calculated data 19 | kpar_par.mac Shows the correlations between two parameter values or 20 | the R-values and parameter values 21 | 22 | The header of each file contains a short description. 23 | -------------------------------------------------------------------------------- /diffev/examples/arctan/REPEAT: -------------------------------------------------------------------------------- 1 | 0 2 | -------------------------------------------------------------------------------- /diffev/examples/arctan/arctan.f: -------------------------------------------------------------------------------- 1 | program arctan 2 | c 3 | implicit none 4 | c 5 | integer generation 6 | integer member 7 | integer children 8 | integer npar 9 | integer i,ii 10 | c 11 | real r(3) 12 | real exper(2,2001) 13 | real x,y 14 | real rval 15 | real sumrz,sumrn 16 | c 17 | character*18 trials 18 | character*18 result 19 | c 20 | open(7,file='GENERATION',status='old') 21 | read(7,*) 22 | read(7,*) generation,member,children,npar 23 | close(7) 24 | c 25 | open(7,file='DATA/data.noisy',status='old') 26 | read(7,*) 27 | read(7,*) 28 | do i=1,2001 29 | read(7,*) exper(1,i),exper(2,i) 30 | enddo 31 | close(7) 32 | c 33 | c 34 | do i=1,children 35 | write(trials,1000) i 36 | write(result,1100) i 37 | do ii=15,18 38 | if(trials(ii:ii).eq.' ') trials(ii:ii) = '0' 39 | if(result(ii:ii).eq.' ') result(ii:ii) = '0' 40 | enddo 41 | open(7,file=trials,status='old') 42 | read(7,*) 43 | read(7,*) 44 | read(7,*) 45 | read(7,*) 46 | read(7,*) 47 | do ii=1,npar 48 | read(7,*) r(ii) 49 | enddo 50 | close(7) 51 | sumrz = 0.0 52 | sumrn = 0.0 53 | do ii=1,2001 54 | x = exper(1,ii) 55 | y = r(1)*atan(abs(x-r(2))/r(3)) 56 | sumrz = sumrz + (exper(2,ii)-y)**2 57 | sumrn = sumrn + (exper(2,ii) )**2 58 | enddo 59 | rval = sqrt(sumrz/sumrn) 60 | open(8,file=result,status='unknown') 61 | write(8,2000) i,rval 62 | close(8) 63 | enddo 64 | c 65 | 1000 format('DIFFEV/Trials.',i4) 66 | 1100 format('DIFFEV/Result.',i4) 67 | 2000 format(i4,f12.8) 68 | end 69 | -------------------------------------------------------------------------------- /diffev/examples/arctan/arctan.mac: -------------------------------------------------------------------------------- 1 | set prompt,redirect 2 | ################################################################################ 3 | # 4 | # arctan.mac 5 | # 6 | ################################################################################ 7 | # 8 | # This macro reads the parameter values for a user supplied generation and 9 | # member. It calculates the function and displays the experimental data, the 10 | # calculated function and the difference. 11 | # 12 | # @kdraw generation,member 13 | # generation may be any generation number or -1 for the current one 14 | # 15 | ################################################################################ 16 | # 17 | variable integer,generation 18 | variable integer,member 19 | variable integer,children 20 | variable integer,parameters 21 | variable integer,kid 22 | fclose all 23 | # 24 | rese 25 | # 26 | # Get generation numbers, number of members, children and parameters 27 | # 28 | fopen 1,GENERATION 29 | # 30 | fget 1,generation,member,children,parameters 31 | fclose 1 32 | # 33 | # load the requested generation, and read all parameters for the 34 | # requested member 35 | # 36 | do kid=1,children 37 | fopen 1,"DIFFEV/Trials.%4D",kid 38 | fget 1 39 | fget 1 40 | fget 1 41 | fget 1 42 | fget 1 43 | fget 1,r[11] 44 | fget 1,r[12] 45 | fget 1,r[13] 46 | fclose 1 47 | # 48 | # Now load data and calculate functiion 49 | # 50 | rese 51 | load xy,DATA/data.noisy 52 | func r[11]*(atan((abs(r[0 ]-r[12] ))/r[13])),xmin[1],xmax[1],0.1 53 | rval 1,2,one 54 | fopen 1,"DIFFEV/Result.%4D",kid 55 | fput 1, kid,res[2] 56 | fclose 1 57 | enddo 58 | # 59 | exit 60 | -------------------------------------------------------------------------------- /diffev/examples/arctan/clean: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # 3 | rm -f DIFFEV/*.* 4 | rm -f arctan 5 | rm -f GENERATION 6 | -------------------------------------------------------------------------------- /diffev/examples/arctan/diffev.mac: -------------------------------------------------------------------------------- 1 | # 2 | # diffev.mac 3 | # 4 | ############################################################################### 5 | # 6 | # Main DIFFEV macro. 7 | # After parameter definition and initialization, a loop repeatedly calls 8 | # the slave program which calculates the cost function and the R-value, 9 | # while DIFFEV compares the new R-values and generates a new generation. 10 | # 11 | # If the number in file "REPEAT" is equal to 1, the loop is continued 12 | # 13 | @diffev_setup 14 | init 15 | # 16 | i[0] = 1 17 | # 18 | #do while(i[0].eq.1) 19 | do i[0]=1,100 20 | system ./arctan 21 | compare 22 | # fopen 1, REPEAT 23 | # fget 1,i[0] 24 | # fclose 1 25 | enddo 26 | -------------------------------------------------------------------------------- /diffev/examples/arctan/diffev_continue.mac: -------------------------------------------------------------------------------- 1 | # 2 | # diffev.mac 3 | # 4 | ############################################################################### 5 | # 6 | # Main DIFFEV macro. Continuation of a refinement 7 | # After parameter definition and initialization, a loop repeatedly calls 8 | # the slave program which calculates the cost function and the R-value, 9 | # while DIFFEV compares the new R-values and generates a new generation. 10 | # 11 | # If the number in file "REPEAT" is equal to 1, the loop is continued 12 | # 13 | @diffev_setup 14 | # 15 | fopen 1,GENERATION 16 | fget 1,pop_gen[1],pop_n[1],pop_c[1],pop_dimx[1] 17 | fclose 1 18 | # 19 | do i[0]=1,100 20 | # system ./arctan 21 | system ./arctan 22 | compare 23 | enddo 24 | -------------------------------------------------------------------------------- /diffev/examples/arctan/fit.mac: -------------------------------------------------------------------------------- 1 | set prompt,off 2 | # 3 | # fit.mac 4 | # 5 | ################################################################################ 6 | # 7 | # Attempt to refine the function by least squares fit 8 | # 9 | # @fit height,position,width,slow 10 | # height estimate for the parameter "height" 11 | # position estimate for the parameter "position" 12 | # width estimate for the parameter "width " 13 | # slow control parameter, small values force a fast fit, large 14 | # values force the fit to creep more slowly to the minimum. 15 | # 16 | rese 17 | load xy,DATA/data.noisy 18 | skal -50,150,0,210 19 | mark 20 | achx x 21 | achy Value 22 | fnam off 23 | tit1 Experimental data 24 | tit2 comparativly noisy data 25 | plot 26 | wait return 27 | fit 1 28 | p[1] = $1 29 | p[2] = $2 30 | p[3] = $3 31 | func fx,3,p[1]*(atan((abs(r[0]-p[2]))/p[3])) 32 | cycle 10 33 | urf $3 34 | show 35 | wait return 36 | run 37 | exit 38 | skal 39 | mark 40 | plot 41 | set prompt,on 42 | -------------------------------------------------------------------------------- /diffev/examples/arctan/kcompare.mac: -------------------------------------------------------------------------------- 1 | set prompt,redirect 2 | # 3 | # kcompare.mac 4 | # 5 | # This macro calculates the function and the corresponding R-value 6 | # 7 | # 8 | variable integer,generation 9 | variable integer,member 10 | variable integer,children 11 | variable integer,parameters 12 | fclose all 13 | # 14 | rese 15 | # 16 | fopen 1,GENERATION 17 | 18 | fget 1,generation,member,children,parameters 19 | fclose 1 20 | # 21 | do i[0]=1,children 22 | fopen 1,"DIFFEV/Resultate.%4D",i[0] 23 | fopen 2,"DIFFEV/Versuche.%4D",i[0] 24 | fget 2,generation,member,children,parameters 25 | fget 2,i[1] 26 | fget 2,r[11] 27 | fget 2,r[12] 28 | fget 2,r[13] 29 | # 30 | rese 31 | load xy,DATA/data.noisy 32 | func r[11]*(atan((abs(r[0 ]-r[12] ))/r[13])),xmin[1],xmax[1],0.1 33 | # ccal add,wy,1,-101 34 | # ccal add,wy,2,-101 35 | rval 1,2,one 36 | echo " R-value %12.8f",res[1] 37 | echo "weighted R-value %12.8f",res[2] 38 | fformat 1,i4 39 | fformat 2,f12.8 40 | fput 1,i[0],res[2] 41 | fclose all 42 | enddo 43 | exit 44 | -------------------------------------------------------------------------------- /diffev/examples/arctan/kpara.mac: -------------------------------------------------------------------------------- 1 | rese 2 | i[0]=$1 3 | load sc, DIFFEV/Summary, 1, 1,(i[0]-1)*4 + 6 4 | load sc, DIFFEV/Summary, 1, 1,(i[0]-1)*4 + 7 5 | load sc, DIFFEV/Summary, 1, 1,(i[0]-1)*4 + 8 6 | load sc, DIFFEV/Summary, 1, 1,(i[0]-1)*4 + 9 7 | #kcal add,1,4 8 | #kcal sub,1,4 9 | mtyp 1,3 10 | mtyp 2,3 11 | mtyp 3,3 12 | #kmtyp 5,3 13 | #kmtyp 6,3 14 | mcol 1,3 15 | mcol 2,1 16 | mcol 3,1 17 | #kmcol 5,3 18 | #kmcol 6,3 19 | lcol 1,3 20 | lcol 2,1 21 | lcol 3,1 22 | ltyp 1,1 23 | ltyp 2,1 24 | ltyp 3,1 25 | #klcol 5,3 26 | #klcol 6,3 27 | kfra 1, 1,2,3 28 | #kfra 1, 1,2,3,5,6 29 | # 30 | if($1.eq.0) then 31 | tit2 R-value versus generation 32 | tit1 33 | achx Generation 34 | achy R-value 35 | else 36 | tit1 37 | tit2 "Parameter %d versus generation",$1 38 | achx Generation 39 | achy "parameter %d",$1 40 | endif 41 | skal 42 | plot 43 | -------------------------------------------------------------------------------- /diffev/examples/arctan/kpara_90.mac: -------------------------------------------------------------------------------- 1 | # kpara.mac 2 | # 3 | ############################################################ 4 | # 5 | # Shows the evolution of R-value or parameters as function 6 | # of the generations 7 | # 8 | ############################################################ 9 | # 10 | if($0.ne.1) then 11 | echo 12 | echo "Usage:" 13 | echo "@kpara " 14 | echo 15 | echo For the R-value parameter should be zero 16 | echo 17 | wait return 18 | continue kuplot 19 | endif 20 | # 21 | rese 22 | i[0]=$1 23 | i[0]= 0 24 | load sc, "DIFFEV/Summary.%4D",$1, 1, 1,(i[0]-1)*4 + 6 25 | load sc, "DIFFEV/Summary.%4D",$1, 1, 1,(i[0]-1)*4 + 7 26 | load sc, "DIFFEV/Summary.%4D",$1, 1, 1,(i[0]-1)*4 + 8 27 | load sc, "DIFFEV/Summary.%4D",$1, 1, 1,(i[0]-1)*4 + 9 28 | do i[0]=1,np[1] 29 | dy[1,i[0]] = y[4,i[0]] 30 | enddo 31 | mtyp 1,3 32 | mtyp 2,3 33 | mtyp 3,3 34 | mcol 1,3 35 | mcol 2,1 36 | mcol 3,1 37 | lcol 1,3 38 | lcol 2,1 39 | lcol 3,1 40 | ltyp 1,1 41 | ltyp 2,1 42 | ltyp 3,1 43 | etyp 1,2 44 | # 45 | kfra 1, 1,2,3 46 | skal 47 | mark 48 | tit1 Refinement of VS 080 K Data 49 | if($1.eq.0)then 50 | tit2 "R-value; current Generation %d",xmax[1] 51 | achy R-value 52 | else 53 | tit2 "Parameter No. %d; current Generation %d",$1,xmax[1] 54 | achy "Parameter No. %d",$1 55 | endif 56 | achx Generation 57 | fnam off 58 | plot 59 | -------------------------------------------------------------------------------- /diffev/examples/arctan/kuplot.mac: -------------------------------------------------------------------------------- 1 | set prompt,redirect 2 | ################################################################################ 3 | # 4 | # kuplot.mac 5 | # 6 | ################################################################################ 7 | # 8 | # Displays the development of the R-value or a of a parameter versus the 9 | # generations. 10 | # The average value with error bars and the maximum and minimum value at 11 | # each generation are plotted. 12 | # 13 | ################################################################################ 14 | # 15 | # @kuplot generation,parameter number 16 | # generation may be any generation number or -1 for the current one 17 | # parameter number is zero for R-value 18 | # 19 | ################################################################################ 20 | # 21 | rese 22 | # 23 | # Load from Summary file: sigma, minimum, maximum, and average value 24 | # 25 | load st, DIFFEV/Summary ,1, 1,2+($1)*4 + 3 26 | load st, DIFFEV/Summary ,1, 1,2+($1)*4 + 2 27 | load st, DIFFEV/Summary ,1, 1,2+($1)*4 + 1 28 | load st, DIFFEV/Summary ,1, 1,2+($1)*4 29 | do i[0]=1,np[1] 30 | dy[4,i[0]] = y[1,i[0]] 31 | enddo 32 | # 33 | # make pretty plot 34 | # 35 | ltyp 4,1 36 | ltyp 3,1 37 | ltyp 2,1 38 | mtyp 4,3 39 | mtyp 3,3 40 | mtyp 2,3 41 | etyp 4,2 42 | ltyp 1,0 43 | mtyp 1,0 44 | lcol 4,3 45 | lcol 3,6 46 | lcol 2,6 47 | mcol 4,3 48 | mcol 3,6 49 | mcol 2,6 50 | ecol 4,3 51 | kfra 1,4,3,2 52 | tit1 Development of fit versus generation 53 | achx Generation 54 | skal 55 | r[0] = (ymax[2]-ymin[3])*0.05 56 | if($1.eq.0) then 57 | skal 0,xmax[4],0,ymax[2]*1.05 58 | tit2 R-Value 59 | achy R-Value 60 | else 61 | skal 0,xmax[4],ymin[3]-r[0],ymax[2]+r[0] 62 | tit2 "Parameter Nr. %d",$1 63 | achy "Parameter Nr. %d",$1 64 | endif 65 | mark 66 | plot 67 | eval y[4,np[4]] 68 | wait return 69 | # 70 | # plot the last 30 generation in detail 71 | # 72 | r[1]=max(0,xmax[4]-30) 73 | if($1.eq.0) then 74 | skal r[1],xmax[4]+1 75 | else 76 | skal r[1],xmax[4]+1 77 | endif 78 | plot 79 | set prompt,on 80 | -------------------------------------------------------------------------------- /diffev/examples/arctan/loop.mac: -------------------------------------------------------------------------------- 1 | system ./arctan 2 | compare 3 | -------------------------------------------------------------------------------- /diffev/examples/arctan/main.mac: -------------------------------------------------------------------------------- 1 | @diffev_setup.mac 2 | init 3 | system ./arctan 4 | compare 5 | system ./arctan 6 | compare 7 | eval pop_gen[1] 8 | -------------------------------------------------------------------------------- /diffev/examples/arctan/second.mac: -------------------------------------------------------------------------------- 1 | @diffev_setup.mac 2 | fopen 1,GENERATION 3 | fget 1,pop_gen[1],pop_n[1],pop_c[1],pop_dimx[1] 4 | fclose 1 5 | -------------------------------------------------------------------------------- /diffev/examples/arctan/wdiffev.mac: -------------------------------------------------------------------------------- 1 | # 2 | # wdiffev.mac 3 | # 4 | ############################################################################### 5 | # 6 | # Main DIFFEV macro. WINDOWS version 7 | # After parameter definition and initialization, a loop repeatedly calls 8 | # the slave program which calculates the cost function and the R-value, 9 | # while DIFFEV compares the new R-values and generates a new generation. 10 | # 11 | # If the number in file "REPEAT" is equal to 1, the loop is continued 12 | # 13 | # The only difference to the macro diffev.mac is that here the arctan 14 | # function is calculated using a macro rather than teh arctan.f program. 15 | # 16 | @diffev_setup 17 | init 18 | # 19 | i[0] = 1 20 | # 21 | #do while(i[0].eq.1) 22 | do i[0]=1,100 23 | sys kuplot < arctan.mac 24 | compare 25 | # fopen 1, REPEAT 26 | # fget 1,i[0] 27 | # fclose 1 28 | enddo 29 | -------------------------------------------------------------------------------- /diffev/examples/parabola/cleanup.mac: -------------------------------------------------------------------------------- 1 | system rm -rf DIFFEV/* 2 | system rm -rf TEMP/* 3 | system rm -rf FINAL/* 4 | system rm -rf GENERATION 5 | -------------------------------------------------------------------------------- /diffev/examples/parabola/diffev_increase.mac: -------------------------------------------------------------------------------- 1 | pop_dimx[1] = pop_dimx[1] + 1 2 | # 3 | # Parameter E, cube term 4 | # 5 | ipar = ipar + 1 6 | pop_name ipar, cube 7 | pop_xmin[ipar] = -100.0 8 | pop_xmax[ipar] = 100.0 9 | pop_smin[ipar] = -10.0 10 | pop_smax[ipar] = 10.0 11 | pop_sig [ipar] = 0.2 12 | type real,ipar 13 | refine all 14 | init ipar 15 | -------------------------------------------------------------------------------- /diffev/examples/parabola/diffev_increase_cube.mac: -------------------------------------------------------------------------------- 1 | pop_dimx[1] = pop_dimx[1] + 1 2 | # 3 | # Parameter E, cube term 4 | # 5 | ipar = ipar + 1 6 | pop_name ipar, cube 7 | pop_xmin[ipar] = -100.0 8 | pop_xmax[ipar] = 100.0 9 | pop_smin[ipar] = -1.0 10 | pop_smax[ipar] = 1.0 11 | pop_sig [ipar] = 0.2 12 | type real,ipar 13 | refine all 14 | init ipar 15 | -------------------------------------------------------------------------------- /diffev/examples/parabola/diffev_run.mac: -------------------------------------------------------------------------------- 1 | do i[0]=1,500 2 | # sys kuplot < kup_diffev.mac 3 | system ./function 4 | sys kuplot < kup.select.mac 5 | compare 6 | enddo 7 | -------------------------------------------------------------------------------- /diffev/examples/parabola/diffev_setup.mac: -------------------------------------------------------------------------------- 1 | # 2 | # this is the initial generation, start as zero 3 | # 4 | pop_gen[1] = 0 5 | # 6 | pop_n[1] = 10 7 | pop_c[1] = 10 8 | pop_dimx[1] = 3 9 | ipar = 0 10 | # 11 | # Parameter A, constant term 12 | # 13 | ipar = ipar + 1 14 | pop_name ipar, constant 15 | pop_xmin[ipar] = -20000.0 16 | pop_xmax[ipar] = 20000.0 17 | pop_smin[ipar] = -200.0 18 | pop_smax[ipar] = 200.0 19 | pop_sig [ipar] = 0.2 20 | type real,ipar 21 | # 22 | # Parameter B, linear term 23 | # 24 | ipar = ipar + 1 25 | pop_name ipar, linear 26 | pop_xmin[ipar] = -10000.0 27 | pop_xmax[ipar] = 10000.0 28 | pop_smin[ipar] = -50.0 29 | pop_smax[ipar] = 50.0 30 | pop_sig [ipar] = 0.2 31 | type real,ipar 32 | # 33 | # Parameter C, quadratic term 34 | # 35 | ipar = ipar + 1 36 | pop_name ipar, square 37 | pop_xmin[ipar] = -10000.0 38 | pop_xmax[ipar] = 10000.0 39 | pop_smin[ipar] = -10.0 40 | pop_smax[ipar] = 10.0 41 | pop_sig [ipar] = 0.2 42 | type real,ipar 43 | # 44 | #constr abs(p[1]).lt.0.8000 45 | #constr p[2]**2+p[3]**2.lt.6.2500 46 | # 47 | # diff_cr is the cross over probability 48 | # 49 | diff_cr[1] = 0.7 50 | # 51 | # the difference vector between two parameters is multiplied by diff_f 52 | # Good values for this multiplier seem to be in this range. 53 | # 54 | diff_f[1] = 0.8 55 | # 56 | diff_k[1] = 1.0 57 | diff_lo[1] = 0.0 58 | refine all 59 | # 60 | donor random 61 | selection best,all 62 | # 63 | trialfile DIFFEV/Trials 64 | restrial DIFFEV/Results 65 | logfile DIFFEV/Parameter 66 | summary DIFFEV/Summary 67 | -------------------------------------------------------------------------------- /diffev/examples/parabola/function: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tproffen/DiffuseCode/cafd7934ec4e96d3feadafb99c8d0ecce43de3c1/diffev/examples/parabola/function -------------------------------------------------------------------------------- /diffev/examples/parabola/kpara.mac: -------------------------------------------------------------------------------- 1 | # kpara.mac 2 | # 3 | ############################################################ 4 | # 5 | # Shows the evolution of R-value or parameters as function 6 | # of the generations 7 | # 8 | ############################################################ 9 | # 10 | if($0.ne.1) then 11 | echo 12 | echo "Usage:" 13 | echo "@ksingle " 14 | echo 15 | echo For the R-value parameter should be zero 16 | echo 17 | wait return 18 | continue kuplot 19 | endif 20 | # 21 | rese 22 | i[0]=$1 23 | load sc, DIFFEV/Summary, 1, 1,(i[0]-1)*4 + 6 24 | load sc, DIFFEV/Summary, 1, 1,(i[0]-1)*4 + 7 25 | load sc, DIFFEV/Summary, 1, 1,(i[0]-1)*4 + 8 26 | load sc, DIFFEV/Summary, 1, 1,(i[0]-1)*4 + 9 27 | do i[0]=1,np[1] 28 | dy[1,i[0]] = y[4,i[0]] 29 | enddo 30 | mtyp 1,3 31 | mtyp 2,3 32 | mtyp 3,3 33 | mcol 1,3 34 | mcol 2,1 35 | mcol 3,1 36 | lcol 1,3 37 | lcol 2,1 38 | lcol 3,1 39 | ltyp 1,1 40 | ltyp 2,1 41 | ltyp 3,1 42 | etyp 1,2 43 | # 44 | kfra 1, 1,2,3 45 | skal 46 | mark 47 | tit1 Refinement of a polynomial 48 | if($1.eq.0)then 49 | tit2 R-value 50 | achy R-value 51 | else 52 | tit2 "Parameter No. %d",$1 53 | achy "Parameter No. %d",$1 54 | endif 55 | achx Generation 56 | fnam off 57 | plot 58 | -------------------------------------------------------------------------------- /diffev/examples/parabola/ksingle.mac: -------------------------------------------------------------------------------- 1 | # 2 | rese 3 | # 4 | # 5 | variable integer,generation 6 | variable integer,member 7 | variable integer,children 8 | variable integer,parameters 9 | variable integer,kid 10 | # 11 | kid = $1 12 | # 13 | # 14 | fclose all 15 | # 16 | fopen 1,GENERATION 17 | fget 1,generation,member,children,parameters 18 | fclose 1 19 | # 20 | # Read parameter values 21 | # 22 | fopen 1,"DIFFEV/Trials.%4D",kid 23 | fget 1 24 | fget 1 25 | fget 1 26 | fget 1 27 | fget 1 28 | do i[0]=1,parameters 29 | fget 1,r[100+i[0]] 30 | enddo 31 | fclose 1 32 | # 33 | # calculate all R-values; 34 | # 35 | # 36 | load xy,DATA/function.data 37 | load xy,"FINAL/final.%4D",kid 38 | # 39 | # match scal,1,2 40 | skal 41 | # 42 | kcal sub,1,2 43 | # 44 | mtyp 1,0 45 | mtyp 2,0 46 | mtyp 3,0 47 | ltyp 1,1 48 | ltyp 2,1 49 | ltyp 3,1 50 | lcol 1,3 51 | lcol 2,1 52 | lcol 3,6 53 | skal 54 | mark 55 | tit1 Refinement of a parabola 56 | tit2 "Member no. %d in Generation %d",$1,generation 57 | achx 2\gH 58 | achy Intensity 59 | plot 60 | rval 1,2,one 61 | -------------------------------------------------------------------------------- /diffev/examples/parabola/kup.select.mac: -------------------------------------------------------------------------------- 1 | set prompt,redirect 2 | set error,exit 3 | #@kup.backup compare 4 | @kup.backup best 5 | exit 6 | -------------------------------------------------------------------------------- /diffev/examples/parabola/kup_diffev.mac: -------------------------------------------------------------------------------- 1 | set prompt,redirect 2 | set error,exit 3 | 4 | # main macro for optimisation of a polynomial 5 | # Reads the current parameter set, calculates the polynomials 6 | # writes the calculated function and the R-value 7 | # 8 | ############################################################################### 9 | # 10 | variable integer, generation 11 | variable integer, member 12 | variable integer, children 13 | variable integer, parameters 14 | variable integer, kid 15 | # 16 | variable real, par_a 17 | variable real, par_b 18 | variable real, par_c 19 | variable real, par_d 20 | variable real, par_e 21 | # 22 | fopen 1,GENERATION 23 | fget 1,generation,member, children,parameters 24 | fclose 1 25 | # 26 | sys rm -f DIFFEV/Results 27 | # 28 | do kid=1,children 29 | do i[0]=1,10 30 | r[200+i[0]] = 0.0 31 | enddo 32 | # 33 | fopen 2, "DIFFEV/Trials.%4D",kid 34 | fget 2 35 | fget 2 36 | fget 2 37 | fget 2 38 | fget 2 39 | do i[0]=1,parameters 40 | fget 2, r[200+i[0]] 41 | enddo 42 | fclose 2 43 | par_a = r[201] 44 | par_b = r[202] 45 | par_c = r[203] 46 | par_d = r[204] 47 | par_e = r[205] 48 | # 49 | rese 50 | load xy,DATA/function.data 51 | # 52 | func par_a + par_b*r[0] + par_c*r[0]**2 +par_d*r[0]**3 + par_e*r[0]*+4,-3,3,0.01 53 | # 54 | rval 1,2,one 55 | fopen 1,"DIFFEV/Results.%4D",kid 56 | fformat 1,i6 57 | fformat 2,f12.8 58 | fput 1,i[2],res[2] 59 | fclose 1 60 | enddo 61 | fclose all 62 | exit 63 | -------------------------------------------------------------------------------- /diffev/examples/parabola/make_func.mac: -------------------------------------------------------------------------------- 1 | # 2 | # make_func.mac 3 | ################################################################################ 4 | # 5 | variable real, const 6 | variable real, lin 7 | variable real, squ 8 | variable real, trd 9 | variable real, cub 10 | # 11 | const = 100 12 | lin = -30 13 | squ = -15 14 | trd = 8 15 | cub = -0.1 16 | # 17 | r[100] = const 18 | r[101] = lin 19 | r[102] = squ 20 | r[103] = trd 21 | r[104] = cub 22 | # 23 | rese 24 | func const + lin*r[0] + squ*r[0]**2 + trd*r[0]**3 + cub*r[0]**4,-10,10,0.01 25 | ksav 1 26 | outf DATA/function.data 27 | run 28 | skal 29 | mark 30 | plot 31 | -------------------------------------------------------------------------------- /diffev/prog/constraint.f90: -------------------------------------------------------------------------------- 1 | MODULE constraint 2 | !- 3 | ! Variables needed to define the constraints 4 | !+ 5 | ! 6 | USE precision_mod 7 | ! 8 | SAVE 9 | PUBLIC 10 | ! 11 | CHARACTER (LEN=PREC_STRING),DIMENSION(:), ALLOCATABLE :: constr_line 12 | ! 13 | INTEGER :: MAX_CONSTR ! Maximum constraint number 14 | INTEGER ,DIMENSION(:), ALLOCATABLE :: constr_length 15 | INTEGER :: constr_number 16 | ! 17 | END MODULE constraint 18 | -------------------------------------------------------------------------------- /diffev/prog/diff_evol.f90: -------------------------------------------------------------------------------- 1 | MODULE diff_evol 2 | !- 3 | ! Variables needed to define the differential evolution process 4 | !+ 5 | use precision_mod 6 | SAVE 7 | PUBLIC 8 | ! 9 | INTEGER, PARAMETER :: ADD_TO_RANDOM = 0 10 | INTEGER, PARAMETER :: ADD_TO_BEST = 1 11 | ! 12 | INTEGER, PARAMETER :: SEL_COMP = 0 13 | INTEGER, PARAMETER :: SEL_BEST_ALL = 1 14 | INTEGER, PARAMETER :: SEL_BEST_CHILD = 2 15 | ! 16 | INTEGER :: diff_donor_mode 17 | INTEGER :: diff_sel_mode 18 | ! 19 | REAL(kind=PREC_DP) :: diff_cr 20 | REAL(kind=PREC_DP) :: diff_f 21 | REAL(kind=PREC_DP) :: diff_k 22 | REAL(kind=PREC_DP) :: diff_local 23 | ! 24 | END MODULE diff_evol 25 | -------------------------------------------------------------------------------- /diffev/prog/diffev_branch.f90: -------------------------------------------------------------------------------- 1 | SUBROUTINE diffev_branch(zeile, length, lreset, lloop) 2 | ! 3 | ! Specific DIFFEV Version of a branch subroutine 4 | ! Call DISCUS/KUPLOT via system 5 | ! Currently this gives an error message in a stand alone 6 | ! program 7 | ! 8 | USE errlist_mod 9 | ! 10 | IMPLICIT NONE 11 | ! 12 | CHARACTER (LEN=*), INTENT(IN) :: zeile 13 | INTEGER , INTENT(IN) :: length 14 | LOGICAL , INTENT(IN) :: lreset 15 | integer , INTENT(IN) :: lloop 16 | ! 17 | ier_num = -7 18 | ier_typ = ER_COMM 19 | ! 20 | END SUBROUTINE diffev_branch 21 | -------------------------------------------------------------------------------- /diffev/prog/diffev_config.f90: -------------------------------------------------------------------------------- 1 | MODULE diffev_config 2 | !####################################################################### 3 | ! 4 | ! DIFFEV Configuration file 5 | !####################################################################### 6 | ! 7 | ! MAX_CONSTR_TRIAL : Maximum number of attemps to fulfill a constraint 8 | ! 9 | SAVE 10 | PUBLIC 11 | ! 12 | INTEGER, PARAMETER :: MAX_CONSTR_TRIAL = 5000 13 | ! 14 | ! 15 | !####################################################################### 16 | ! 17 | END MODULE diffev_config 18 | -------------------------------------------------------------------------------- /diffev/prog/diffev_do_exit.f90: -------------------------------------------------------------------------------- 1 | MODULE diffev_do_exit_mod 2 | ! 3 | CONTAINS 4 | ! 5 | SUBROUTINE diffev_do_exit 6 | ! 7 | USE diffev_allocate_appl 8 | USE diffev_random 9 | USE exit_mod 10 | USE prompt_mod 11 | !+ 12 | ! Clean exit from the program DIFFEV ;-) 13 | !- 14 | IMPLICIT none 15 | INTEGER :: length 16 | ! 17 | CALL diffev_best_macro ! Make a macro to recreate best parameters 18 | ! 19 | length = 3 20 | CALL diffev_do_deallocate_appl ( 'all',length) 21 | CALL exit_all 22 | ! 23 | IF (output_io.ne.OUTPUT_SCREEN) then 24 | CLOSE (output_io) 25 | ENDIF 26 | ! 27 | END SUBROUTINE diffev_do_exit 28 | ! 29 | SUBROUTINE diffev_emergency_save 30 | ! 31 | ! Write the GENERATION , PARAMETER SUMMARY files 32 | ! Currently left blank intentionally, as these 33 | ! Files are updated regularly at points where it 34 | ! makes sense to update them 35 | ! 36 | IMPLICIT NONE 37 | ! 38 | !WRITE(*,*) ' SAVING STRUCTURE TO EMERGENCY.STRU ' 39 | ! 40 | ! 41 | END SUBROUTINE diffev_emergency_save 42 | ! 43 | SUBROUTINE diffev_emergency_mpi 44 | ! 45 | ! Closes down MPI in case of emergency. 46 | ! Currently just a finalize, to be developed further 47 | ! 48 | USE diffev_mpi_mod 49 | IMPLICIT NONE 50 | ! 51 | CALL run_mpi_finalize 52 | ! 53 | ! 54 | END SUBROUTINE diffev_emergency_mpi 55 | ! 56 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 57 | ! 58 | END MODULE diffev_do_exit_mod 59 | -------------------------------------------------------------------------------- /diffev/prog/diffev_loop_mpi.f90: -------------------------------------------------------------------------------- 1 | SUBROUTINE diffev_loop_mpi(prog_n, prog_l, mac_n, mac_l, out_n, out_l, repeat, nindiv) 2 | ! 3 | ! This routine is called if a "run_mpi" command occurs within a do loop or 4 | ! if block and we are running discus_suite without MPI active. 5 | ! 6 | ! Copies the run_mpi parameters detected from a "run_mpi" within a loop 7 | ! into the senddata structure. 8 | ! 9 | USE population 10 | USE diffev_random 11 | USE run_mpi_mod 12 | ! 13 | IMPLICIT NONE 14 | ! 15 | CHARACTER (LEN=*), INTENT(IN) :: prog_n 16 | CHARACTER (LEN=*), INTENT(IN) :: mac_n 17 | CHARACTER (LEN=*), INTENT(IN) :: out_n 18 | INTEGER , INTENT(IN) :: prog_l 19 | INTEGER , INTENT(IN) :: mac_l 20 | INTEGER , INTENT(IN) :: out_l 21 | LOGICAL , INTENT(IN) :: repeat 22 | INTEGER , INTENT(IN) :: nindiv 23 | ! 24 | run_mpi_senddata%prog = prog_n 25 | run_mpi_senddata%prog_l = prog_l 26 | run_mpi_senddata%mac = mac_n 27 | run_mpi_senddata%mac_l = mac_l 28 | run_mpi_senddata%out = out_n 29 | run_mpi_senddata%out_l = out_l 30 | run_mpi_senddata%repeat = repeat 31 | run_mpi_senddata%nindiv = nindiv 32 | ! 33 | run_mpi_senddata%generation = pop_gen ! Current GENERATION no 34 | run_mpi_senddata%member = pop_n ! Number of members 35 | run_mpi_senddata%children = pop_c ! Number of children 36 | run_mpi_senddata%parameters = pop_dimx ! Number of parameters 37 | !run_mpi_senddata%use_socket = .false. 38 | ! 39 | run_mpi_senddata%l_get_state = l_get_random_state 40 | ! 41 | END SUBROUTINE diffev_loop_mpi 42 | -------------------------------------------------------------------------------- /diffev/prog/diffev_reset.f90: -------------------------------------------------------------------------------- 1 | MODULE diffev_reset 2 | ! 3 | CONTAINS 4 | ! 5 | SUBROUTINE diffev_do_reset 6 | !- 7 | ! Reset DIFFEV to system start 8 | !+ 9 | ! 10 | USE diffev_allocate_appl 11 | USE diffev_blk_appl 12 | USE population 13 | use run_mpi_mod 14 | USE diff_evol 15 | USE do_variable_mod 16 | USE precision_mod 17 | ! 18 | IMPLICIT NONE 19 | ! 20 | CHARACTER (LEN=PREC_STRING) :: zeile 21 | INTEGER , PARAMETER :: MAXW=2 22 | INTEGER :: ianz 23 | CHARACTER(LEN=PREC_STRING), DIMENSION(1:MAXW) :: cpara 24 | INTEGER , DIMENSION(1:MAXW) :: lpara 25 | ! 26 | LOGICAL, PARAMETER :: is_diffev = .TRUE. 27 | INTEGER :: lcomm 28 | INTEGER :: i 29 | ! 30 | ! Remove all parameter names from the variable entry 31 | ianz = 2 32 | DO i=1, pop_dimx 33 | cpara(1) = 'delete' 34 | lpara(1) = 6 35 | cpara(2) = pop_name(i) 36 | lpara(2) = LEN_TRIM(pop_name(i)) 37 | CALL del_variables (MAXW, ianz, cpara, lpara, is_diffev) 38 | ENDDO 39 | ! 40 | zeile ='default' 41 | lcomm = 7 42 | ! 43 | pop_gen = 0 44 | pop_n = 1 45 | pop_c = 1 46 | pop_dimx = 1 47 | ! 48 | pop_current_trial = .FALSE. 49 | pop_initialized = .FALSE. 50 | pop_result_file_rd = .FALSE. 51 | pop_trial_file_wrt = .FALSE. 52 | pop_current = .FALSE. 53 | ! 54 | CALL diffev_do_allocate_appl(zeile,lcomm) 55 | CALL diffev_initarrays 56 | call run_mpi_senddata_init ! Initialize run_mpi_senddata 57 | ! 58 | END SUBROUTINE diffev_do_reset 59 | ! 60 | END MODULE diffev_reset 61 | -------------------------------------------------------------------------------- /diffev/prog/no_mpi.f90: -------------------------------------------------------------------------------- 1 | MODULE DIFFEV_MPI_MOD 2 | ! 3 | CONTAINS 4 | !*****7*************************************************************** 5 | SUBROUTINE RUN_MPI_INIT 6 | ! 7 | ! NO MPI Version for standalone 8 | ! 9 | USE gen_mpi_mod 10 | USE errlist_mod 11 | USE variable_mod 12 | ! 13 | IMPLICIT none 14 | ! 15 | ! 16 | gen_mpi_myid = 0 17 | gen_mpi_numprocs = 1 18 | gen_mpi_active = .false. 19 | ier_num = 0 20 | ier_typ = ER_NONE 21 | var_val(VAR_NUM_NODES) = 0 22 | ! 23 | !write(*,*) 'MPI is not active ' 24 | ! 25 | END SUBROUTINE RUN_MPI_INIT 26 | ! 27 | !*****7*************************************************************** 28 | SUBROUTINE RUN_MPI_MASTER 29 | ! 30 | !USE gen_mpi_mod 31 | USE errlist_mod 32 | ! 33 | IMPLICIT none 34 | ! 35 | ier_num = -21 36 | ier_typ = ER_APPL 37 | ! 38 | ! 39 | END SUBROUTINE RUN_MPI_MASTER 40 | ! 41 | !*****7*************************************************************** 42 | SUBROUTINE RUN_MPI_SLAVE 43 | ! 44 | !USE run_mpi_mod 45 | USE errlist_mod 46 | ! 47 | IMPLICIT none 48 | ! 49 | ! 50 | ier_num = -21 51 | ier_typ = ER_APPL 52 | ! 53 | END SUBROUTINE RUN_MPI_SLAVE 54 | ! 55 | !*****7*************************************************************** 56 | SUBROUTINE run_mpi_finalize 57 | ! 58 | IMPLICIT none 59 | ! 60 | END SUBROUTINE run_mpi_finalize 61 | END MODULE DIFFEV_MPI_MOD 62 | -------------------------------------------------------------------------------- /diffev/prog/sysmac/modify_trial.mac: -------------------------------------------------------------------------------- 1 | # 2 | # modify_trial.mac 3 | # 4 | ################################################################################ 5 | # 6 | # Changes a parameter in the Trial file 7 | # 8 | # IN this template parameters 4 and 5 are changed, each to a 9 | # random number in the interval 0.08 to 0.18. 10 | # Adjust as needed. 11 | # 12 | ############################################################################### 13 | variable integer,generation 14 | variable integer,member 15 | variable integer,children 16 | variable integer,parameters 17 | variable integer,kid 18 | # 19 | fopen 1,GENERATION 20 | fget 1,generation,member,children,parameters 21 | fclose 1 22 | # 23 | do kid=2,member 24 | fopen 2,"DIFFEV/Trials.%4D",kid 25 | fget 2,i[31],i[32],i[33],i[34] 26 | fget 2,i[1] 27 | fget 2 28 | do i[3] = 1,parameters 29 | fget 2,r[200+i[3]] 30 | enddo 31 | fclose 2 32 | # 33 | r[204] = 0.080 + 0.1*ran(0) 34 | r[205] = 0.080 + 0.1*ran(0) 35 | # 36 | fopen 1, "DIFFEV/Trials.%4D",kid 37 | fput 1,'# generation members children parameters' 38 | fformat 1,i8 39 | fformat 2,i10 40 | fformat 3,i10 41 | fformat 4,i10 42 | fput 1,generation,member,children,parameters 43 | fput 1,'# current member' 44 | fformat 1,i5 45 | fput 1,kid 46 | fput 1,'# parameter list' 47 | fformat 1,e20.10 48 | fformat 2,i6 49 | do i[0]=1,parameters 50 | echo " wrote Parameter %3d ; %20.10f",i[0],r[200+i[0]] 51 | fput 1,r[200+i[0]],i[0] 52 | enddo 53 | fclose 1 54 | enddo 55 | -------------------------------------------------------------------------------- /diffev/prog/sysmac/systest.mac: -------------------------------------------------------------------------------- 1 | set prompt,off,on,save 2 | # 3 | # $Id: systest.mac,v 1.1.1.1 2012/06/09 16:17:43 rbneder Exp $ 4 | # 5 | echo "DIFFEV system macros seem to work ..." 6 | set prompt,old 7 | -------------------------------------------------------------------------------- /diffev/prog/triple_perm.f90: -------------------------------------------------------------------------------- 1 | MODULE triple_perm 2 | ! 3 | PRIVATE 4 | PUBLIC :: do_triple_perm 5 | ! 6 | CONTAINS 7 | ! 8 | !******************************************************************************* 9 | ! 10 | SUBROUTINE do_triple_perm (j, j1, j2, j3, n) 11 | ! 12 | USE lib_random_func 13 | USE random_mod 14 | IMPLICIT none 15 | ! 16 | ! 17 | INTEGER, INTENT(IN ) :: j 18 | INTEGER, INTENT(INOUT) :: j1 19 | INTEGER, INTENT(INOUT) :: j2 20 | INTEGER, INTENT(INOUT) :: j3 21 | INTEGER, INTENT(IN ) :: n 22 | ! 23 | j1 = mod (j + int (ran1 (idum) * (n - 1) ), n) + 1 24 | DO while (j1.eq.j) 25 | j1 = mod (j1, n) + 1 26 | ENDDO 27 | j2 = mod (j + int (ran1 (idum) * (n - 1) ), n) + 1 28 | DO while (j2.eq.j.or.j2.eq.j1) 29 | j2 = mod (j2, n) + 1 30 | ENDDO 31 | j3 = mod (j + int (ran1 (idum) * (n - 1) ), n) + 1 32 | DO while (j3.eq.j.or.j3.eq.j1.or.j3.eq.j2) 33 | j3 = mod (j3, n) + 1 34 | ENDDO 35 | ! 36 | END SUBROUTINE do_triple_perm 37 | ! 38 | END MODULE triple_perm 39 | -------------------------------------------------------------------------------- /discus/prog/atom_env_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE atom_env_mod 2 | !+ 3 | ! 4 | ! include file for atomic environment variables 5 | !- 6 | use precision_mod 7 | ! 8 | SAVE 9 | ! 10 | INTEGER, PARAMETER :: MAX_ATOM_ENV = 6000 11 | INTEGER, PARAMETER :: MAX_ATOM_ENV_D = MAX_ATOM_ENV+1 12 | ! 13 | INTEGER :: atom_env( 0:MAX_ATOM_ENV) = 0 14 | REAL(kind=PREC_DP) :: atom_pos(3,0:MAX_ATOM_ENV) = 0.0 15 | REAL(kind=PREC_DP) :: atom_dis( 0:MAX_ATOM_ENV) = 0.0 16 | ! 17 | END MODULE atom_env_mod 18 | -------------------------------------------------------------------------------- /discus/prog/celltoindex.f90: -------------------------------------------------------------------------------- 1 | MODULE celltoindex_mod 2 | ! 3 | CONTAINS 4 | ! 5 | !*****7***************************************************************** 6 | ! 7 | SUBROUTINE celltoindex (icell, isite, iatom) 8 | !- 9 | ! calculates in which unit cell on which site the atom is 10 | !+ 11 | USE discus_config_mod 12 | USE crystal_mod 13 | USE errlist_mod 14 | ! 15 | IMPLICIT none 16 | ! 17 | INTEGER, DIMENSION(3), INTENT(IN) :: icell 18 | INTEGER , INTENT(IN) :: isite 19 | INTEGER , INTENT(OUT) :: iatom 20 | ! 21 | iatom = ( (icell(3) - 1) * cr_icc(1) * cr_icc(2) + & 22 | (icell(2) - 1) * cr_icc(1) + (icell(1) - 1) ) & 23 | * cr_ncatoms + isite 24 | ! 25 | END SUBROUTINE celltoindex 26 | ! 27 | !*****7***************************************************************** 28 | ! 29 | SUBROUTINE indextocell (iatom, icell, isite) 30 | !- 31 | ! calculates in which unit cell on which site the atom is 32 | !+ 33 | USE discus_config_mod 34 | USE crystal_mod 35 | USE errlist_mod 36 | ! 37 | IMPLICIT none 38 | ! 39 | INTEGER , INTENT(IN) :: iatom 40 | INTEGER, DIMENSION(3), INTENT(OUT) :: icell 41 | INTEGER , INTENT(OUT) :: isite 42 | ! 43 | INTEGER :: ia 44 | ! 45 | ia = iatom - 1 46 | ! 47 | icell(3) = INT(ia / cr_icc(1) / cr_icc(2) / cr_ncatoms) + 1 48 | ia = ia - (icell(3) - 1) * cr_icc (1) * cr_icc (2) * cr_ncatoms 49 | icell(2) = INT(ia / cr_icc(1) / cr_ncatoms) + 1 50 | ia = ia - (icell(2) - 1) * cr_icc(1) * cr_ncatoms 51 | icell(1) = INT(ia / cr_ncatoms) + 1 52 | isite = ia - (icell(1) - 1) * cr_ncatoms + 1 53 | ! 54 | END SUBROUTINE indextocell 55 | ! 56 | !*****7***************************************************************** 57 | ! 58 | END MODULE celltoindex_mod 59 | -------------------------------------------------------------------------------- /discus/prog/debye_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE debye_mod 2 | !+ 3 | ! 4 | ! Contains all variables for Debye formula 5 | !- 6 | ! 7 | use precision_mod 8 | SAVE 9 | ! 10 | INTEGER :: MAXLOOK =1 ! = MAXSCAT*(MAXSCAT+1)/2 11 | INTEGER :: MAXHIST =1 ! 12 | INTEGER :: MAXDSCAT =1 ! 13 | INTEGER :: MAXDQXY =1 ! 14 | INTEGER :: DEB_MAXMASK =1 ! 15 | ! 16 | INTEGER :: nlook 17 | ! 18 | REAL(kind=PREC_DP), DIMENSION(:), ALLOCATABLE :: rsf ! (1:MAXQXY) 19 | REAL(kind=PREC_DP), DIMENSION(:), ALLOCATABLE :: sinetab ! (0:2**16-1) 20 | REAL(kind=PREC_DP) :: pow_del_hist = 0.0100000000 ! = 0.001 can be changed by user 21 | LOGICAL :: deb_conv = .FALSE. ! convolute ADP's 22 | ! 23 | END MODULE debye_mod 24 | -------------------------------------------------------------------------------- /discus/prog/demolec_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE demolec_mod 2 | ! 3 | ! 4 | INTEGER :: DEM_MAX_MOLETYPE ! MAX Number of molecule types 5 | INTEGER :: DEM_MAX_ATOMTYPE ! MAX Number of molecule types 6 | INTEGER, DIMENSION(2) :: dem_molerange = 0 ! molecule range is included 7 | INTEGER, DIMENSION(2) :: dem_atomrange = (/1,-1/) ! atom range is included 8 | INTEGER, DIMENSION(0:1) :: dem_sel_prop = (/0,0/) ! Property selection mask 9 | LOGICAL, DIMENSION(:), ALLOCATABLE :: dem_lmoletype ! molecule types are selected 10 | LOGICAL, DIMENSION(:), ALLOCATABLE :: dem_latomtype ! atom types are selected 11 | ! 12 | !******************************************************************************* 13 | ! 14 | END MODULE demolec_mod 15 | -------------------------------------------------------------------------------- /discus/prog/discus.f90: -------------------------------------------------------------------------------- 1 | PROGRAM discus 2 | ! 3 | USE discus_setup_mod 4 | USE discus_loop_mod 5 | USE variable_mod 6 | ! 7 | IMPLICIT none 8 | ! 9 | LOGICAL, PARAMETER :: standalone = .true. 10 | ! 11 | EXTERNAL :: discus_sigint 12 | ! 13 | CALL discus_setup(standalone) 14 | CALL discus_set_sub 15 | CALL SIGNAL(2, discus_sigint) 16 | var_val(VAR_STATE) = var_val(VAR_IS_TOP) 17 | var_val(VAR_PROGRAM) = var_val(VAR_DISCUS) 18 | CALL discus_loop 19 | ! 20 | END PROGRAM discus 21 | ! 22 | SUBROUTINE discus_sigint 23 | ! 24 | ! Handle DISCUS specific part of a CTRL-C interrupt. 25 | ! CALLED within standalone DISCUS only 26 | ! This subroutine calls all DISCUS specific emergency handlers 27 | ! which can also be called from the SUITE 28 | ! 29 | USE discus_exit_mod 30 | USE exit_mod 31 | IMPLICIT NONE 32 | CHARACTER(LEN=1) :: dummy 33 | WRITE(*,*) 34 | WRITE(*,*) ' EMERGENCY Shutdown with USER CTRL-C Interrupt' 35 | ! 36 | CALL discus_emergency_save 37 | CALL exit_all 38 | ! 39 | WRITE(*,*) 40 | WRITE(*,*) ' DISCUS closed by User Request CTRL-C ' 41 | WRITE(*,*) ' For final close down hit ENTER key' 42 | READ(*,'(a)') dummy 43 | STOP ! Terminate program 44 | ! 45 | END SUBROUTINE discus_sigint 46 | -------------------------------------------------------------------------------- /discus/prog/discus_branch.f90: -------------------------------------------------------------------------------- 1 | SUBROUTINE discus_branch(zeile, length, lreset, lloop) 2 | ! 3 | ! Specific DISCUS Version of a branch subroutine 4 | ! Call KUPLOT via system 5 | ! 6 | USE errlist_mod 7 | ! 8 | IMPLICIT NONE 9 | ! 10 | CHARACTER (LEN=*), INTENT(IN) :: zeile 11 | INTEGER , INTENT(IN) :: length 12 | LOGICAL , INTENT(IN) :: lreset 13 | integer , INTENT(IN) :: lloop 14 | ! 15 | ier_num = -7 16 | ier_typ = ER_COMM 17 | ! 18 | END SUBROUTINE discus_branch 19 | -------------------------------------------------------------------------------- /discus/prog/discus_config_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE discus_config_mod 2 | ! 3 | SAVE 4 | !####################################################################### 5 | ! 6 | ! 7 | ! DISCUS Configuration file 8 | !####################################################################### 9 | ! (1) Crystal dimensions 10 | ! 11 | ! MAXSCAT : Maximum number of different atomtypes 12 | ! NMAX : Maximum number of atoms 13 | ! 14 | INTEGER :: MAXSCAT = 1 15 | INTEGER :: NMAX = 1 16 | ! 17 | !####################################################################### 18 | ! (2) Fourier transform 19 | ! 20 | ! MAXQXY : Maximum number of points in Q 21 | ! CFPKT : Number of points in SIN(THETA/LAMBDA) lookup table 22 | ! CFINC : Increment for SIN(THETA/LAMBDA) table. The lookup 23 | ! table ranges from 0 to (CFPKT+1)*CFINC 24 | ! 25 | ! 26 | INTEGER, dimension(3) :: MAXQXY 27 | INTEGER, PARAMETER :: CFPKT = 9999 28 | REAL(KIND=KIND(0.0D0)), PARAMETER :: CFINC = 0.001D0 29 | ! 30 | !####################################################################### 31 | ! 32 | END MODULE discus_config_mod 33 | -------------------------------------------------------------------------------- /discus/prog/discus_crystal.f90: -------------------------------------------------------------------------------- 1 | MODULE crystal_task_mod 2 | !- 3 | ! Collection of basic tasks for the crystal 4 | !+ 5 | ! 6 | CONTAINS 7 | ! 8 | !******************************************************************************* 9 | ! 10 | SUBROUTINE crystal_calc_mass 11 | ! 12 | ! Calculate crystal mass 13 | ! 14 | USE crystal_mod 15 | USE element_data_mod 16 | ! 17 | USE precision_mod 18 | ! 19 | IMPLICIT NONE 20 | ! 21 | character(len=4) :: at_name ! Atom name 22 | INTEGER :: iscat 23 | INTEGER :: i 24 | ! 25 | cr_mass = 0.0E0 26 | cr_nreal = 0.0E0 27 | ! 28 | ! Prepare and calculate average atom numbers 29 | ! 30 | cr_niscat = 0 31 | DO i=1,cr_natoms 32 | cr_niscat(cr_iscat(1,i)) = cr_niscat(cr_iscat(1,i)) + 1 33 | ENDDO 34 | cr_nreal = SUM(NINT(cr_niscat(1:cr_nscat)*cr_occ(1:cr_nscat))) ! Add real atom numbers 35 | ! 36 | DO iscat=1,cr_nscat 37 | if(cr_scat_equ(iscat)) then ! Equivalent atom name exists 38 | at_name = cr_at_equ(iscat) ! Use the corresponding equivalen atom name 39 | else 40 | at_name = cr_at_lis(iscat) ! Use regular atom name 41 | endif 42 | cr_mass = cr_mass + cr_niscat(iscat)*cr_occ(iscat)*get_mass(at_name) 43 | ! cr_mass = cr_mass + cr_niscat(iscat)*cr_occ(iscat)*get_mass(cr_at_lis(iscat)) 44 | ENDDO 45 | ! 46 | END SUBROUTINE crystal_calc_mass 47 | ! 48 | !******************************************************************************* 49 | ! 50 | 51 | END MODULE crystal_task_mod 52 | -------------------------------------------------------------------------------- /discus/prog/discus_exit.f90: -------------------------------------------------------------------------------- 1 | MODULE discus_exit_mod 2 | ! 3 | CONTAINS 4 | SUBROUTINE discus_do_exit 5 | !+ 6 | ! Clean exit from the program DISCUS ;-) 7 | !- 8 | USE exit_mod 9 | USE prompt_mod 10 | ! 11 | IMPLICIT none 12 | ! 13 | CALL exit_all 14 | END SUBROUTINE discus_do_exit 15 | ! 16 | SUBROUTINE discus_emergency_save 17 | ! 18 | ! Write the structure to a file EMERGENCY.STRU 19 | ! 20 | USE discus_config_mod 21 | USE crystal_mod 22 | USE save_menu 23 | ! 24 | CHARACTER (LEN=14) :: strucfile 25 | ! 26 | WRITE(*,*) ' SAVING STRUCTURE TO EMERGENCY.STRU ' 27 | ! 28 | CALL save_default_setting ! Set default save flags 29 | strucfile = 'EMERGENCY.STRU' 30 | CALL save_keyword(strucfile) 31 | ! 32 | END SUBROUTINE discus_emergency_save 33 | END MODULE discus_exit_mod 34 | -------------------------------------------------------------------------------- /discus/prog/discus_nexus_no.f90: -------------------------------------------------------------------------------- 1 | MODULE nexus_discus 2 | ! 3 | USE errlist_mod 4 | ! 5 | PRIVATE 6 | PUBLIC nexus_write 7 | ! 8 | CONTAINS 9 | ! 10 | ! Dummy routines, as no NeXus is available 11 | ! 12 | SUBROUTINE nexus_write ( value, laver) 13 | ! 14 | IMPLICIT NONE 15 | INTEGER, INTENT(IN) :: value 16 | LOGICAL, INTENT(IN) :: laver 17 | ! 18 | ier_num = -117 19 | ier_typ = ER_APPL 20 | ier_msg(1) = 'To write a NeXus file you need to' 21 | ier_msg(2) = 'install the NeXus library ' 22 | ier_msg(3) = 'and the NeXus version of DISCUS' 23 | ! 24 | ! 25 | END SUBROUTINE nexus_write 26 | END MODULE nexus_discus 27 | -------------------------------------------------------------------------------- /discus/prog/discus_pdf_file.f90: -------------------------------------------------------------------------------- 1 | ! 2 | ! OBSOLETE; standalone no longer supported 3 | !******************************************************************************* 4 | ! 5 | ! Version for stan alone DISCUS 6 | ! The file is always written to hard disk 7 | ! 8 | SUBROUTINE pdf_save_file(cdummy, pdf_rfmin, pdf_rfmax, pdf_deltar, pdf_us_int,& 9 | pdf_calc_l, pdf_calc_u, pdf_skal,pdf_calc) 10 | ! 11 | USE discus_config_mod 12 | USE errlist_mod 13 | USE precision_mod 14 | ! 15 | IMPLICIT NONE 16 | ! 17 | CHARACTER (LEN=*), INTENT(IN) :: cdummy 18 | REAL(kind=PREC_DP), INTENT(IN) :: pdf_rfmin 19 | REAL(kind=PREC_DP), INTENT(IN) :: pdf_rfmax 20 | REAL(kind=PREC_DP), INTENT(IN) :: pdf_deltar 21 | INTEGER, INTENT(IN) :: pdf_us_int 22 | INTEGER, INTENT(IN) :: pdf_calc_l 23 | INTEGER, INTENT(IN) :: pdf_calc_u 24 | REAL(kind=PREC_DP), INTENT(IN) :: pdf_skal 25 | REAL(PREC_DP), DIMENSION(pdf_calc_l:pdf_calc_u), INTENT(IN) :: pdf_calc 26 | ! 27 | INTEGER :: nmi 28 | INTEGER :: nma 29 | INTEGER :: nmd 30 | INTEGER :: i 31 | REAL(kind=PREC_DP) :: r 32 | ! 33 | CALL oeffne (57, cdummy, 'unknown') 34 | IF (ier_num.eq.0) then 35 | nmi = nint (pdf_rfmin / pdf_deltar) 36 | nma = nint (pdf_rfmax / pdf_deltar) 37 | nmd = pdf_us_int ! step width = (delta r user)/(deltar internal) 38 | DO i = nmi, nma, nmd 39 | r = REAL(i) * pdf_deltar 40 | WRITE (57, 5000) r, pdf_skal * pdf_calc (i), 0.0, 1.0 41 | ENDDO 42 | CLOSE (57) 43 | ENDIF 44 | ! 45 | 5000 FORMAT (F9.4,3X,F21.10,5X,2(F6.2,1X)) 46 | ! 47 | END SUBROUTINE pdf_save_file 48 | -------------------------------------------------------------------------------- /discus/prog/discus_powder_file.f90: -------------------------------------------------------------------------------- 1 | ! 2 | ! Version for stand alone DISCUS 3 | ! The file is always written to hard disk 4 | ! 5 | SUBROUTINE powder_do_write (outfile, npkt_wrt, xwrt, ywrt) 6 | ! 7 | USE errlist_mod 8 | use precision_mod 9 | IMPLICIT NONE 10 | ! 11 | CHARACTER (LEN=*) , INTENT(IN) :: outfile 12 | INTEGER , INTENT(IN) :: npkt_wrt 13 | REAL(kind=PREC_DP) , DIMENSION(0:npkt_wrt ) , INTENT(IN) :: xwrt 14 | REAL(kind=PREC_DP) , DIMENSION(0:npkt_wrt ) , INTENT(IN) :: ywrt 15 | ! 16 | INTEGER, PARAMETER :: iff = 2 17 | INTEGER :: ii 18 | ! 19 | CALL oeffne (iff, outfile, 'unknown') 20 | IF(ier_num == 0) THEN 21 | DO ii = 0,npkt_wrt 22 | WRITE( iff, *) xwrt(ii),ywrt(ii) 23 | ENDDO 24 | CLOSE(iff) 25 | ENDIF 26 | ! 27 | END SUBROUTINE powder_do_write 28 | -------------------------------------------------------------------------------- /discus/prog/discus_set_sub.f90: -------------------------------------------------------------------------------- 1 | MODULE discus_setup_sub_mod 2 | ! 3 | CONTAINS 4 | ! 5 | !******************************************************************************* 6 | ! 7 | SUBROUTINE discus_set_sub 8 | ! 9 | ! Sets the specific DISCUS interfaces for routines that are refecenced in 10 | ! LIB_F90 by their generic names 11 | ! 12 | use discus_errlist_mod 13 | !use discus_mache_kdo_mod 14 | use discus_update_mod 15 | USE set_sub_generic_mod 16 | ! 17 | INTERFACE 18 | SUBROUTINE discus_mache_kdo (line, lend, length) 19 | ! 20 | CHARACTER (LEN= * ), INTENT(INOUT) :: line 21 | LOGICAL , INTENT( OUT) :: lend 22 | INTEGER , INTENT(INOUT) :: length 23 | ! 24 | END SUBROUTINE discus_mache_kdo 25 | END INTERFACE 26 | ! 27 | INTERFACE 28 | SUBROUTINE discus_branch(zeile, length, lreset, lloop) 29 | ! 30 | CHARACTER (LEN=*), INTENT(IN) :: zeile 31 | INTEGER , INTENT(IN) :: length 32 | LOGICAL , INTENT(IN) :: lreset 33 | integer , INTENT(IN) :: lloop 34 | ! 35 | END SUBROUTINE discus_branch 36 | END INTERFACE 37 | ! 38 | p_mache_kdo => discus_mache_kdo 39 | p_errlist_appl => discus_errlist_appl 40 | p_ersetz_para => discus_ersetz_para 41 | p_upd_para => discus_upd_para 42 | p_calc_intr_spec => discus_calc_intr_spec 43 | p_calc_intr_log_spec=> discus_calc_intr_log_spec 44 | p_validate_var_spec => discus_validate_var_spec 45 | p_branch => discus_branch 46 | !p_loop_mpi => dummy_loop_mpi 47 | p_get_var_type => discus_get_var_type 48 | ! 49 | END SUBROUTINE discus_set_sub 50 | ! 51 | !******************************************************************************* 52 | ! 53 | END MODULE discus_setup_sub_mod 54 | -------------------------------------------------------------------------------- /discus/prog/discus_super_waves.f90: -------------------------------------------------------------------------------- 1 | module super_waves_mod 2 | ! 3 | contains 4 | ! 5 | !******************************************************************************* 6 | ! 7 | real(kind=PREC_DP ) function sup_fun_sine(amp, average, arg1, arg2) 8 | !- 9 | ! Sine type wave function : amp * sin(2PI*arg) + average 10 | !+ 11 | use precision_mod 12 | use wink_mod 13 | ! 14 | implicit none 15 | ! 16 | real(kind=PREC_DP), intent(in) :: amp 17 | real(kind=PREC_DP), intent(in) :: average 18 | real(kind=PREC_DP), intent(in) :: arg1 19 | real(kind=PREC_DP), intent(in) :: arg2 20 | ! 21 | sup_fun_sine = amp*sin(zpi*arg1) + average 22 | ! 23 | end function sup_fun_sine 24 | ! 25 | !******************************************************************************* 26 | ! 27 | real(kind=PREC_DP ) function sup_fun_cren(amp, average, arg1, arg2) 28 | !- 29 | ! Crennel type wave function : amp * box(frac(arg)) + average 30 | !+ 31 | ! 32 | use lib_functions_mod 33 | use precision_mod 34 | ! 35 | implicit none 36 | ! 37 | real(kind=PREC_DP), intent(in) :: amp 38 | real(kind=PREC_DP), intent(in) :: average 39 | real(kind=PREC_DP), intent(in) :: arg1 40 | real(kind=PREC_DP), intent(in) :: arg2 41 | ! 42 | real(kind=PREC_DP), parameter :: TOL=1.0D-8 43 | real(kind=PREC_DP) :: arg 44 | ! 45 | arg = frac(arg1) 46 | if(arg<-TOL ) then 47 | arg = frac(arg + 1.0_PREC_DP) 48 | endif 49 | ! 50 | if(arg < arg2 .or. arg > 1.0_PREC_DP-TOL-arg2) then 51 | sup_fun_cren = average + amp 52 | else 53 | sup_fun_cren = average - amp 54 | endif 55 | ! 56 | end function sup_fun_cren 57 | ! 58 | !******************************************************************************* 59 | ! 60 | end module super_waves_mod 61 | -------------------------------------------------------------------------------- /discus/prog/domain_irreg_mod.f90: -------------------------------------------------------------------------------- 1 | module domain_irreg_mod 2 | !- 3 | ! Variables for the irreguarly shaped domeins 4 | !+ 5 | !******************************************************************************* 6 | ! 7 | use precision_mod 8 | ! 9 | integer :: ngroup ! Group size 10 | integer :: mgroup ! Group size short 11 | integer, dimension(:), allocatable :: short ! List of atoms in the current domain 12 | integer :: icent ! Central atom of group 13 | integer :: icent_cr! Central atom in crystal 14 | real(kind=PREC_DP), dimension(3) :: origin ! Origin of this domain 15 | integer , dimension(3) :: orig_off ! Origin of this domain 16 | real(kind=PREC_DP), dimension(:,:), allocatable :: offs ! Offsets from group origin 17 | real(kind=PREC_DP), dimension(:,:), allocatable :: coor ! Coordinates relative to group origin 18 | real(kind=PREC_DP), dimension(3,2) :: maxdim ! Dimensions of this domain 19 | ! 20 | end module domain_irreg_mod 21 | -------------------------------------------------------------------------------- /discus/prog/domaindis_mod.f90: -------------------------------------------------------------------------------- 1 | module domaindis_mod 2 | ! 3 | ! Common block for the microdomain distributions 4 | ! 5 | ! 6 | USE discus_config_mod 7 | use precision_mod 8 | ! 9 | SAVE 10 | ! 11 | INTEGER, PARAMETER :: MD_DOMAIN_CUBE = -1 12 | INTEGER, PARAMETER :: MD_DOMAIN_CYLINDER = -2 13 | INTEGER, PARAMETER :: MD_DOMAIN_SPHERE = -3 14 | INTEGER, PARAMETER :: MD_DOMAIN_FUZZY = -4 15 | INTEGER, PARAMETER :: MD_DOMAIN_IRREG = -5 16 | ! 17 | INTEGER :: md_ori_n = 0 18 | REAL(kind=PREC_DP) :: md_sep_fuz = 0.5 19 | INTEGER :: mv_orient = 0 20 | INTEGER :: mc_num = 0 21 | INTEGER :: mc_type = 1 22 | ! 23 | END module domaindis_mod 24 | -------------------------------------------------------------------------------- /discus/prog/external_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE external_mod 2 | !+ 3 | ! 4 | ! variables needed for the externally computed structure factors 5 | !- 6 | ! 7 | USE molecule_mod 8 | use precision_mod 9 | ! 10 | SAVE 11 | ! 12 | INTEGER, PARAMETER :: EXTE_HLINES = 10 13 | ! 14 | CHARACTER(LEN=200), DIMENSION(:), ALLOCATABLE :: exte_names ! (MOLE_MAX_TYPE) 15 | CHARACTER(LEN=200) :: exte_filename 16 | INTEGER, DIMENSION(:), ALLOCATABLE :: exte_length! (MOLE_MAX_TYPE) 17 | ! 18 | INTEGER, DIMENSION(:), ALLOCATABLE :: exte_type ! (MOLE_MAX_TYPE) 19 | ! 20 | INTEGER :: exte_version 21 | INTEGER :: exte_hdrblks 22 | CHARACTER(LEN=144) :: exte_title 23 | INTEGER :: exte_nrows 24 | INTEGER :: exte_ncols 25 | INTEGER :: exte_layer 26 | INTEGER :: exte_npixelb 27 | INTEGER :: exte_wordord 28 | INTEGER :: exte_longord 29 | INTEGER, DIMENSION(3) :: exte_orig ! (3) 30 | REAL(kind=PREC_DP) :: exte_scale 31 | ! 32 | INTEGER, DIMENSION(3) :: exte_iii ! (3) 33 | REAL(kind=PREC_DP) , DIMENSION(4,4) :: exte_mat ! (4,4) 34 | REAL(kind=PREC_DP) , DIMENSION(4,4) :: exte_rmat ! (4,4) 35 | REAL(kind=PREC_DP) , DIMENSION(4,4) :: exte_rot ! (4,4) 36 | REAL(kind=PREC_DP) , DIMENSION(4,4) :: exte_rrot ! (4,4) 37 | ! 38 | END MODULE external_mod 39 | -------------------------------------------------------------------------------- /discus/prog/gen_add_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE gen_add_mod 2 | ! 3 | ! 4 | ! This file contains subroutines for: 5 | ! include file for additional generator matrizes 6 | ! 7 | ! gen_add_n Number of different additional generators 8 | ! gen_add (4,4,ng) List of all additional generators 9 | ! 10 | !*****7***************************************************************** 11 | ! 12 | use precision_mod 13 | ! 14 | INTEGER, PRIVATE :: ik 15 | INTEGER, PRIVATE :: il 16 | INTEGER, PARAMETER :: GEN_ADD_MAX = 192 17 | ! 18 | INTEGER :: gen_add_n = 0 19 | INTEGER :: gen_add_power(GEN_ADD_MAX) = 1 20 | REAL(kind=PREC_DP) :: gen_add(4,4,0:GEN_ADD_MAX) = & 21 | RESHAPE((/(1.,(0.,0.,0.,0.,1.,ik=1,3),il=0,GEN_ADD_MAX)/),(/4,4,GEN_ADD_MAX+1/)) 22 | ! 23 | END MODULE gen_add_mod 24 | -------------------------------------------------------------------------------- /discus/prog/hdf_write_no.f90: -------------------------------------------------------------------------------- 1 | ! 2 | !*****7***************************************************************** 3 | ! 4 | SUBROUTINE hdf5_write (value, laver, outfile, out_inc, out_eck, out_vi, & 5 | extr_abs, extr_ord, extr_top, & 6 | cr_a0, cr_win, VAL_PDF, VAL_3DPDF, & 7 | ier_num, ier_typ, ER_IO, ER_APPL) 8 | ! 9 | use precision_mod 10 | ! 11 | IMPLICIT NONE 12 | ! 13 | INTEGER, INTENT(IN) :: value 14 | LOGICAL, INTENT(IN) :: laver 15 | CHARACTER(LEN=200), INTENT(IN) :: outfile 16 | INTEGER, DIMENSION(3) , INTENT(IN) :: out_inc 17 | REAL(kind=PREC_DP) , DIMENSION(3,4), INTENT(IN) :: out_eck ! (3,4) 18 | REAL(kind=PREC_DP) , DIMENSION(3,3), INTENT(IN) :: out_vi 19 | integer , intent(in) :: extr_abs 20 | integer , intent(in) :: extr_ord 21 | integer , intent(in) :: extr_top 22 | REAL(kind=PREC_DP) , DIMENSION(3) , INTENT(IN) :: cr_a0 23 | REAL(kind=PREC_DP) , DIMENSION(3) , INTENT(IN) :: cr_win 24 | INTEGER , INTENT(IN) :: VAL_PDF 25 | INTEGER , INTENT(IN) :: VAL_3DPDF 26 | ! 27 | INTEGER, INTENT(OUT) :: ier_num 28 | INTEGER, INTENT(OUT) :: ier_typ 29 | INTEGER, INTENT(IN) :: ER_IO 30 | INTEGER, INTENT(IN) :: ER_APPL 31 | ! 32 | ier_num = -172 ! HDF5 not supported 33 | ier_typ = ER_APPL 34 | ! 35 | END SUBROUTINE hdf5_write 36 | ! 37 | !*****7***************************************************************** 38 | ! 39 | -------------------------------------------------------------------------------- /discus/prog/insert_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE insert_mod 2 | !- 3 | ! Variables needed to insert objects 4 | !+ 5 | ! 6 | use precision_mod 7 | ! 8 | SAVE 9 | ! 10 | INTEGER, PARAMETER :: INS_NEWTYPE = -1 11 | ! 12 | CHARACTER(LEN=4 ) :: ins_obj_atom = 'VOID' 13 | CHARACTER(LEN=200) :: ins_file = ' ' 14 | INTEGER :: ins_CHARACTER = 0 15 | INTEGER :: ins_type = 0 16 | REAL(kind=PREC_DP), DIMENSION(3) :: ins_origin = (/0.0, 0.0, 0.0/) ! (3) 17 | REAL(kind=PREC_DP), DIMENSION(3) :: ins_cent = (/0.0, 0.0, 0.0/) ! (3) 18 | REAL(kind=PREC_DP) :: ins_density = 0.0 19 | REAL(kind=PREC_DP) :: ins_biso = 0.0 20 | REAL(kind=PREC_DP) :: ins_clin = 0.0 21 | REAL(kind=PREC_DP) :: ins_cqua = 0.0 22 | REAL(kind=PREC_DP) :: ins_fuzzy = 0.0 23 | REAL(kind=PREC_DP) :: ins_adp = 0.0 24 | REAL(kind=PREC_DP), DIMENSION(3) :: ins_xaxis = (/1.0, 0.0, 0.0/) ! (3) 25 | REAL(kind=PREC_DP), DIMENSION(3) :: ins_yaxis = (/0.0, 1.0, 0.0/) ! (3) 26 | REAL(kind=PREC_DP), DIMENSION(3) :: ins_zaxis = (/0.0, 0.0, 1.0/) ! (3) 27 | REAL(kind=PREC_DP), DIMENSION(3) :: ins_xdim = (/1.0, 0.0, 0.0/) ! (3) 28 | REAL(kind=PREC_DP), DIMENSION(3) :: ins_ydim = (/0.0, 1.0, 0.0/) ! (3) 29 | REAL(kind=PREC_DP), DIMENSION(3) :: ins_zdim = (/0.0, 0.0, 1.0/) ! (3) 30 | ! 31 | END MODULE insert_mod 32 | -------------------------------------------------------------------------------- /discus/prog/intens_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE intens_mod 2 | !+ 3 | ! Symbolic names for different intensity values 4 | !- 5 | SAVE 6 | ! 7 | INTEGER, PARAMETER :: INTENSITY = 1 8 | INTEGER, PARAMETER :: AMPLITUDE = 2 9 | INTEGER, PARAMETER :: PHASE_ANG = 3 10 | INTEGER, PARAMETER :: REAL_PART = 4 11 | INTEGER, PARAMETER :: IMAG_PART = 5 12 | INTEGER, PARAMETER :: FCALC = 6 13 | ! 14 | END MODULE intens_mod 15 | -------------------------------------------------------------------------------- /discus/prog/interpret.f90: -------------------------------------------------------------------------------- 1 | MODULE interpret_menu 2 | ! 3 | CONTAINS 4 | !*****7***************************************************************** 5 | ! 6 | SUBROUTINE interpret 7 | !- 8 | ! Interpret sets up the menu for interpretation of electron 9 | ! density maps 10 | ! 11 | ! Version : 0.0 12 | ! Date : 24 Dec 1995 13 | ! 14 | ! Author : R.B. Neder (reinhard.neder@fau.de) 15 | !+ 16 | IMPLICIT none 17 | ! 18 | END SUBROUTINE interpret 19 | END MODULE interpret_menu 20 | -------------------------------------------------------------------------------- /discus/prog/inverse_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE inverse_mod 2 | !+ 3 | ! 4 | ! This file contains PARAMETER definitions forr inverse Fourier 5 | ! and Patterson input 6 | !- 7 | INTEGER, PARAMETER :: INV_INV = 0 8 | INTEGER, PARAMETER :: INV_DIFF = 1 9 | INTEGER, PARAMETER :: INV_PATT = 2 10 | INTEGER, PARAMETER :: INV_FCALC = 3 11 | ! 12 | END MODULE inverse_mod 13 | -------------------------------------------------------------------------------- /discus/prog/mc_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE mc_mod 2 | !+ 3 | ! 4 | ! Variables for MONTE-CARLO level 5 | !- 6 | ! 7 | USE discus_config_mod 8 | ! 9 | USE precision_mod 10 | ! 11 | SAVE 12 | ! 13 | INTEGER, PARAMETER :: MC_NONE = 0 14 | INTEGER, PARAMETER :: MC_OCC = 1 15 | INTEGER, PARAMETER :: MC_DISP = 2 16 | INTEGER, PARAMETER :: MC_SPRING = 3 17 | INTEGER, PARAMETER :: MC_ANGLE = 4 18 | INTEGER, PARAMETER :: MC_VECTOR = 5 19 | INTEGER, PARAMETER :: MC_BLEN = 6 20 | INTEGER, PARAMETER :: MC_LENNARD = 7 21 | INTEGER, PARAMETER :: MC_BUCKING = 8 22 | INTEGER, PARAMETER :: MC_REPULSIVE= 9 23 | INTEGER, PARAMETER :: MC_COORDNUM = 10 24 | INTEGER, PARAMETER :: MC_UNI = 11 25 | INTEGER, PARAMETER :: MC_GROUP = 12 26 | INTEGER, PARAMETER :: MC_PREF = 13 27 | ! 28 | INTEGER, PARAMETER :: MC_N_ENERGY = 13 29 | ! 30 | LOGICAL, PARAMETER :: MMC_IS_ATOM = .TRUE. 31 | LOGICAL, PARAMETER :: MMC_IS_MOLE = .FALSE. 32 | ! 33 | CHARACTER(LEN=200) :: mo_atom(3) 34 | ! 35 | INTEGER :: mo_energy 36 | INTEGER :: mo_mode,mo_local 37 | INTEGER(KIND=PREC_INT_LARGE) :: mo_cyc,mo_feed 38 | ! 39 | REAL(kind=PREC_DP), DIMENSION(:) , ALLOCATABLE :: mo_ach_corr ! (200) 40 | REAL(kind=PREC_DP), DIMENSION(:,: ), ALLOCATABLE :: mo_maxmove ! (4,0:DEF_MAXSCAT) 41 | REAL(kind=PREC_DP), DIMENSION(:,: ), ALLOCATABLE :: mo_maxmove_mole! (4,0:DEF_MAXSCAT) 42 | REAL(kind=PREC_DP), DIMENSION(:,: ), ALLOCATABLE :: mo_maxrota_mole! (4,0:DEF_MAXSCAT) 43 | REAL(kind=PREC_DP) :: mo_kt 44 | LOGICAL :: mo_sel_atom 45 | ! 46 | END MODULE mc_mod 47 | -------------------------------------------------------------------------------- /discus/prog/mole_env_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE mole_env_mod 2 | !+ 3 | ! 4 | ! include file for molecular environment variables 5 | !- 6 | USE atom_env_mod 7 | use precision_mod 8 | ! 9 | SAVE 10 | ! 11 | INTEGER, PARAMETER :: MAX_MOLE_ENV = MAX_ATOM_ENV 12 | ! 13 | INTEGER , DIMENSION(0:MAX_MOLE_ENV) :: mole_env ! (0:MAX_MOLE_ENV) 14 | REAL(kind=PREC_DP), DIMENSION(3,MAX_MOLE_ENV) :: mole_pos ! (3,MAX_MOLE_ENV) 15 | ! 16 | END MODULE mole_env_mod 17 | -------------------------------------------------------------------------------- /discus/prog/output_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE output_mod 2 | !- 3 | ! Common Block und Definitionen der Outputvariablen fuers INCLUDE 4 | !+ 5 | use precision_mod 6 | SAVE 7 | ! 8 | CHARACTER(LEN=200) :: outfile = 'fcalc.dat' 9 | INTEGER :: ityp = 0 10 | INTEGER :: extr_abs = 1 11 | INTEGER :: extr_ord = 2 12 | INTEGER :: extr_top = 3 13 | INTEGER :: rho_extr_abs = 1 14 | INTEGER :: rho_extr_ord = 2 15 | INTEGER :: out_extr_abs = 1 16 | INTEGER :: out_extr_ord = 2 17 | INTEGER :: out_extr_top = 3 18 | INTEGER, DIMENSION(3) :: out_center = 0 ! Center of map in pixels 19 | INTEGER, DIMENSION(3) :: out_pixel = 0 ! Full size of map in pixels 20 | INTEGER :: out_lrange = 0 ! 0=No limit; 1=center; 2=quad 21 | INTEGER :: out_lcenter = 0 ! 0=middle; 1=user 22 | INTEGER :: out_lpixel = 0 ! 0=all pixels, 1 = user values 23 | CHARACTER(LEN=3) :: out_quad = ' ' 24 | INTEGER, DIMENSION(3) :: out_inc ! Number of data points along dimension h,k,l or Q/Theta (2) 25 | REAL(kind=PREC_DP), DIMENSION(3,4) :: out_eck ! (3,4) 26 | REAL(kind=PREC_DP), DIMENSION(3,3) :: out_vi ! (3,3) 27 | CHARACTER(LEN= 3) :: cpow_form = 'tth' 28 | LOGICAL :: out_user_limits = .false. 29 | REAL(kind=PREC_DP), DIMENSION(3) :: out_user_values = (/1.0D0, 10.0D0, 0.01D0/) ! User Qmin, Qmax, Qstep 30 | INTEGER , DIMENSION(3) :: out_user_inc ! Number of data points along dimension h,k,l or Q/Theta (2) 31 | integer :: out_mode = 0 ! Output mode if KUPLOT 0;1;2 == new, old, add 32 | real(kind=PREC_DP) :: out_scale = 1.0D0 33 | ! 34 | END MODULE output_mod 35 | -------------------------------------------------------------------------------- /discus/prog/patters_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE patters_mod 2 | !+ 3 | ! 4 | ! This file contains variables for inverse Fourier and 5 | ! Patterson input 6 | !- 7 | use precision_mod 8 | SAVE 9 | ! 10 | INTEGER, PARAMETER :: PATT_INIT = 0 11 | INTEGER, PARAMETER :: PATT_ADD = 1 12 | INTEGER, PARAMETER :: PATT_NORMAL = 0 13 | INTEGER, PARAMETER :: PATT_SHARP = 1 14 | INTEGER, PARAMETER :: PATT_SUPER = 2 15 | INTEGER, PARAMETER :: PATT_SUBTRACT = 1 16 | ! 17 | CHARACTER(LEN=200), DIMENSION(2) :: rho_file = (/' ',' '/) 18 | INTEGER :: patt_accu = 0 19 | INTEGER, DIMENSION(3) :: rho_inc = (/121,121, 1/) 20 | INTEGER, DIMENSION(2) :: rho_type = (/4,5/) 21 | INTEGER :: patt_sign = -1 22 | INTEGER :: patt_mode = PATT_NORMAL 23 | INTEGER :: patt_origin = 0 24 | INTEGER :: ftyp = 0 25 | LOGICAL :: patt_excl9999 = .false. 26 | LOGICAL :: patt_rsym = .false. 27 | REAL(kind=PREC_DP) , DIMENSION(3,3) :: rho_eck = reshape((/0,0,0, 1,0,0, 0,1,0/),shape(rho_eck)) 28 | REAL(kind=PREC_DP) , DIMENSION(3,2) :: rho_vi = reshape((/0.02,0.0,0.0, 0.0, 0.02,0.0/),shape(rho_vi)) 29 | REAL(kind=PREC_DP) :: patt_scale = 1.0 30 | REAL(kind=PREC_DP) :: patt_excl_val = -9999.0 31 | REAL(kind=PREC_DP) , DIMENSION(20) :: e_aver_f2 = 0.0 32 | REAL(kind=PREC_DP) :: wilson_scale = 1.0 33 | REAL(kind=PREC_DP) :: wilson_b = 0.0 34 | ! 35 | END MODULE patters_mod 36 | -------------------------------------------------------------------------------- /discus/prog/phases_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE phases_mod 2 | !+ 3 | ! variables needed for multiple phases 4 | !- 5 | USE discus_config_mod 6 | USE precision_mod 7 | ! 8 | SAVE 9 | ! 10 | INTEGER :: PHA_MAXPHA = 1 11 | INTEGER :: PHA_MAXPTS = 1 12 | INTEGER :: PHA_MAXSCAT = 1 13 | ! 14 | ! Section for multiple phases 15 | ! 16 | LOGICAL :: pha_multi = .FALSE. ! Multiple phases yes / no 17 | INTEGER :: pha_n = 1 ! number of phases 18 | INTEGER :: pha_curr = 1 ! curent phase 19 | INTEGER , DIMENSION(:) , ALLOCATABLE :: pha_nscat ! No of atom types for each phase ( i) 20 | INTEGER , DIMENSION(:) , ALLOCATABLE :: pha_calc ! Calc mode Comp/Debye each phase ( i) 21 | REAL(KIND=PREC_DP), DIMENSION(:) , ALLOCATABLE :: pha_frac ! weight fraction User intent ( i) 22 | REAL(KIND=PREC_DP), DIMENSION(:) , ALLOCATABLE :: pha_weight ! Weight for each phase ( i) 23 | REAL(KIND=PREC_DP), DIMENSION(:) , ALLOCATABLE :: pha_scale ! Scale temp>frac for each phase ( i) 24 | REAL(KIND=PREC_DP), DIMENSION(:) , ALLOCATABLE :: pha_nreal ! Number real atoms at phase ( i) 25 | REAL(KIND=PREC_DP), DIMENSION(:) , ALLOCATABLE :: pha_ncreal ! Number real atoms /unit call at phase ( i) 26 | REAL(KIND=PREC_DP), DIMENSION(:,:), ALLOCATABLE :: pha_powder ! Powder pattern for each phase (q, i) 27 | REAL(KIND=PREC_DP), DIMENSION(:,:,:), ALLOCATABLE :: pha_form ! Form factors for each phase (q,is,i) 28 | REAL(KIND=PREC_DP), DIMENSION(:,:), ALLOCATABLE :: pha_adp ! B-values ADP for each phase (is, i) 29 | REAL(KIND=PREC_DP), DIMENSION(:,:), ALLOCATABLE :: pha_occ ! Occupancies for each phase (is , i) 30 | INTEGER , DIMENSION(:,:), ALLOCATABLE :: pha_niscat ! Atom numbers of iscat at phasof iscat at phase 31 | ! 32 | ! 33 | END MODULE phases_mod 34 | -------------------------------------------------------------------------------- /discus/prog/pname.inc: -------------------------------------------------------------------------------- 1 | pname = 'discus' 2 | pname_cap = 'DISCUS' 3 | -------------------------------------------------------------------------------- /discus/prog/powder_scat_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE powder_scat_mod 2 | !+ 3 | ! 4 | ! variables needed for the atom lists 5 | !- 6 | USE discus_config_mod 7 | ! 8 | SAVE 9 | ! 10 | INTEGER :: POW_NMAX = 1 11 | INTEGER :: POW_MAXSCAT = 1 12 | ! 13 | INTEGER, DIMENSION(: ), ALLOCATABLE :: pow_nscat ! (MAXSCAT) 14 | INTEGER, DIMENSION(:,:), ALLOCATABLE :: pow_iatom ! (MAXSCAT,NMAX) 15 | ! 16 | ! 17 | END MODULE powder_scat_mod 18 | -------------------------------------------------------------------------------- /discus/prog/prop_para_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE prop_para_mod 2 | !+ 3 | ! 4 | ! Parameter definitions for property settings 5 | !- 6 | SAVE 7 | ! 8 | INTEGER, PARAMETER :: MINPROP = 1 9 | INTEGER, PARAMETER :: MAXPROP = 8 10 | ! 11 | INTEGER, PARAMETER :: PROP_NORMAL = 0 12 | INTEGER, PARAMETER :: PROP_MOLECULE = 1 13 | INTEGER, PARAMETER :: PROP_DOMAIN = 2 14 | INTEGER, PARAMETER :: PROP_OUTSIDE = 3 15 | INTEGER, PARAMETER :: PROP_SURFACE_EXT = 4 16 | INTEGER, PARAMETER :: PROP_SURFACE_INT = 5 17 | INTEGER, PARAMETER :: PROP_LIGAND = 6 18 | INTEGER, PARAMETER :: PROP_TEMP = 7 19 | ! 20 | INTEGER, PARAMETER :: PROP_DECO_ANCHOR = 8 21 | ! 22 | INTEGER, PARAMETER :: PROP_IGNORE = MAXPROP+1 23 | ! 24 | CHARACTER(LEN=8) :: c_prop_letter = 'NMDOEILT' 25 | CHARACTER(LEN=8) :: c_prop_small = 'nmdoeilt' 26 | ! 27 | INTEGER :: prop_user_no = 0 28 | ! 29 | TYPE :: prop_templ 30 | INTEGER :: act 31 | INTEGER :: at_type 32 | INTEGER :: conn_no 33 | CHARACTER(LEN=256) :: conn_name 34 | INTEGER :: n_min 35 | INTEGER :: n_max 36 | INTEGER :: e_min 37 | INTEGER :: e_max 38 | END TYPE prop_templ 39 | ! 40 | TYPE(prop_templ), DIMENSION(:), ALLOCATABLE :: prop_user 41 | ! 42 | END MODULE prop_para_mod 43 | -------------------------------------------------------------------------------- /discus/prog/quad.f90: -------------------------------------------------------------------------------- 1 | MODULE quad_mod 2 | ! 3 | ! function quad has become obsolete 4 | private 5 | ! 6 | CONTAINS 7 | !*****7***************************************************************** 8 | !OLD REAL kind=PREC_DP) FUNCTION quad (h, k, rten) 9 | !+ 10 | ! Calculates the scalar product of h and k. 11 | ! 1/d**2 = h(i)*k(j)*rten(i,j) 12 | !- 13 | !OLD IMPLICIT none 14 | ! 15 | !OLD INTEGER, PARAMETER :: idim = 3 16 | ! 17 | !OLD REAL(KIND=PREC_DP), DIMENSION(3) , INTENT(IN) :: h 18 | !OLD REAL(KIND=PREC_DP), DIMENSION(3) , INTENT(IN) :: k 19 | !OLD REAL(KIND=PREC_DP), DIMENSION(3,3), INTENT(IN) :: rten 20 | ! 21 | !OLD INTEGER i, j 22 | ! 23 | !OLD quad = 0.0 24 | !OLD DO i = 1, idim 25 | !OLD DO j = 1, idim 26 | !OLD quad = quad+h (i) * k (j) * rten (i, j) 27 | !OLD ENDDO 28 | !OLD ENDDO 29 | !OLD END FUNCTION quad 30 | END MODULE quad_mod 31 | -------------------------------------------------------------------------------- /discus/prog/recipro_mod.f90: -------------------------------------------------------------------------------- 1 | module recipro_mod 2 | !+ 3 | ! 4 | ! This file contains variables for inverse Fourier and 5 | ! Patterson input 6 | !- 7 | use precision_mod 8 | ! 9 | save 10 | ! 11 | integer, parameter :: REC_MAX_SYM = 48 12 | ! 13 | integer :: rec_n_sym 14 | real(kind=PREC_DP), dimension(4,4,REC_MAX_SYM) :: rec_sym 15 | ! 16 | end module recipro_mod 17 | -------------------------------------------------------------------------------- /discus/prog/stack_rese.f90: -------------------------------------------------------------------------------- 1 | MODULE stack_rese_mod 2 | ! 3 | CONTAINS 4 | ! 5 | !*****7***************************************************************** 6 | ! 7 | SUBROUTINE do_stack_rese 8 | !- 9 | ! Resets the stacking fault setup 10 | !+ 11 | USE discus_config_mod 12 | USE stack_mod 13 | ! 14 | IMPLICIT none 15 | ! 16 | st_new_form = .TRUE. 17 | st_nlayer = 0 18 | st_ntypes = 0 19 | st_nchem = 0 20 | ! 21 | END SUBROUTINE do_stack_rese 22 | ! 23 | !*****7***************************************************************** 24 | ! 25 | END MODULE stack_rese_mod 26 | -------------------------------------------------------------------------------- /discus/prog/surface_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE surface_mod 2 | !+ 3 | ! 4 | ! Surface related definitions 5 | !- 6 | ! 7 | use precision_mod 8 | ! 9 | SAVE 10 | ! 11 | INTEGER, PARAMETER :: SURF_MAXTYPE = 7 12 | INTEGER, PARAMETER :: SURF_NONE = 0 13 | INTEGER, PARAMETER :: SURF_PLANE = 1 14 | INTEGER, PARAMETER :: SURF_SPHERE = 2 15 | INTEGER, PARAMETER :: SURF_CYLINDER = 3 16 | INTEGER, PARAMETER :: SURF_EDGE = 4 17 | INTEGER, PARAMETER :: SURF_CORNER = 5 18 | INTEGER, PARAMETER :: SURF_LOCAL = 6 19 | ! 20 | INTEGER, PARAMETER :: SURF_SURFACE = 0 21 | INTEGER, PARAMETER :: SURF_DOMAIN = 1 22 | ! 23 | INTEGER :: SURF_MAXSCAT = 0 24 | ! 25 | REAL(kind=PREC_DP) :: SURF_DIST_DEF = 2.55 26 | ! 27 | REAL(kind=PREC_DP), DIMENSION(:), ALLOCATABLE :: surf_ex_dist !(0:MAXSCAT) 28 | REAL(kind=PREC_DP), DIMENSION(:), ALLOCATABLE :: surf_in_dist !(0:MAXSCAT) 29 | ! 30 | LOGICAL :: surf_local_new = .TRUE. 31 | ! 32 | ! 33 | END MODULE surface_mod 34 | -------------------------------------------------------------------------------- /discus/prog/sym_add_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE sym_add_mod 2 | ! 3 | ! 4 | ! This file contains subroutines for: 5 | ! include file for additional symmetry matrizes 6 | ! 7 | ! sym_add_n Number of different additional symmetries 8 | ! sym_add (4,4,ng) List of all additional symmetries 9 | ! 10 | !*****7***************************************************************** 11 | ! 12 | use precision_mod 13 | ! 14 | SAVE 15 | ! 16 | INTEGER, PRIVATE :: ik 17 | INTEGER, PRIVATE :: il 18 | INTEGER, PARAMETER :: SYM_ADD_MAX = 192 19 | ! 20 | INTEGER :: sym_add_n = 0 21 | INTEGER, DIMENSION(SYM_ADD_MAX) :: sym_add_power = 1 22 | REAL(kind=PREC_DP) , DIMENSION(4,4,0:SYM_ADD_MAX) :: sym_add = & 23 | RESHAPE((/(1.,(0.,0.,0.,0.,1.,ik=1,3),il=0,SYM_ADD_MAX)/),(/4,4,SYM_ADD_MAX+1/)) 24 | ! 25 | END MODULE sym_add_mod 26 | -------------------------------------------------------------------------------- /discus/prog/sysmac/systest.mac: -------------------------------------------------------------------------------- 1 | set prompt,off,on,save 2 | # 3 | # $Id: systest.mac,v 1.1.1.1 2012/06/09 16:18:24 rbneder Exp $ 4 | # 5 | echo "DISCUS system macros seem to work ..." 6 | set prompt,old 7 | -------------------------------------------------------------------------------- /discus/prog/transfrm_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE transfrm_mod 2 | !+ 3 | ! 4 | ! variables needed for the unit cell transformations 5 | !- 6 | ! 7 | use precision_mod 8 | ! 9 | INTEGER, PRIVATE :: ik 10 | SAVE 11 | ! 12 | INTEGER, PARAMETER :: TRAN_INP_F = 0 13 | INTEGER, PARAMETER :: TRAN_INP_FI = 1 14 | INTEGER, PARAMETER :: TRAN_INP_G = 2 15 | INTEGER, PARAMETER :: TRAN_INP_GI = 3 16 | ! 17 | INTEGER :: TRAN_MAXSCAT = 1 18 | INTEGER :: TRAN_MAXSITE = 1 19 | ! 20 | INTEGER :: tran_start = 1 21 | INTEGER :: tran_end = -1 22 | INTEGER :: tran_inp = TRAN_INP_G 23 | LOGICAL, DIMENSION(:), ALLOCATABLE :: tran_latom ! (0:TRAN_MAXSCAT) 24 | LOGICAL, DIMENSION(:), ALLOCATABLE :: tran_lsite ! (0:TRAN_MAXSCAT) 25 | ! 26 | LOGICAL :: tran_oold = .true. 27 | LOGICAL :: tran_sel_atom = .true. 28 | REAL(kind=PREC_DP) :: tran_orig(3) = 0.0 29 | REAL(kind=PREC_DP) :: tran_det = 1.0 30 | REAL(kind=PREC_DP) :: tran_g (4,4) = & 31 | RESHAPE((/1.,(0.,0.,0.,0.,1.,ik=1,3)/),SHAPE(tran_g )) 32 | REAL(kind=PREC_DP) :: tran_gi (4,4) = & 33 | RESHAPE((/1.,(0.,0.,0.,0.,1.,ik=1,3)/),SHAPE(tran_gi)) 34 | REAL(kind=PREC_DP) :: tran_f (4,4) = & 35 | RESHAPE((/1.,(0.,0.,0.,0.,1.,ik=1,3)/),SHAPE(tran_f )) 36 | REAL(kind=PREC_DP) :: tran_fi (4,4) = & 37 | RESHAPE((/1.,(0.,0.,0.,0.,1.,ik=1,3)/),SHAPE(tran_fi)) 38 | REAL(kind=PREC_DP) :: tran_deltahkl = 0.001 39 | ! 40 | ! 41 | END MODULE transfrm_mod 42 | -------------------------------------------------------------------------------- /discus/prog/unitcell_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE unitcell_mod 2 | ! 3 | ! 4 | ! This file contains subroutines for: 5 | ! input conditions for the unit cell files 6 | ! 7 | ! gen_sta Sequence status of generators 8 | ! 9 | !*****7***************************************************************** 10 | ! 11 | SAVE 12 | ! 13 | INTEGER, PARAMETER :: GEN_CENTER = 0 14 | INTEGER, PARAMETER :: GEN_SYMM = 1 15 | ! 16 | INTEGER :: gen_sta = GEN_SYMM 17 | ! 18 | END MODULE unitcell_mod 19 | -------------------------------------------------------------------------------- /discus/prog/update_cr_dim.f90: -------------------------------------------------------------------------------- 1 | MODULE update_cr_dim_mod 2 | ! 3 | CONTAINS 4 | ! 5 | !********************************************************************** 6 | ! 7 | SUBROUTINE update_cr_dim 8 | !- 9 | ! Updates the crystal dimensions to the current values 10 | !+ 11 | USE discus_config_mod 12 | USE crystal_mod 13 | ! 14 | IMPLICIT none 15 | ! 16 | INTEGER :: i, j ! Counter variables 17 | ! 18 | ! Set initial values 19 | ! 20 | IF(cr_natoms > 0) THEN 21 | DO j = 1, 3 22 | cr_dim(j, 1) = cr_pos(j, 1) 23 | cr_dim(j, 2) = cr_pos(j, 1) 24 | ENDDO 25 | ELSE 26 | DO j = 1, 3 27 | cr_dim(j, 1) = 1.e10 28 | cr_dim(j, 1) = - 1.e10 29 | ENDDO 30 | ENDIF 31 | ! 32 | ! Update values from all atoms in crystal 33 | ! 34 | DO i = 1, cr_natoms 35 | DO j = 1, 3 36 | cr_dim(j, 1) = MIN(cr_dim(j, 1), cr_pos(j, i)) 37 | cr_dim(j, 2) = MAX(cr_dim(j, 2), cr_pos(j, i)) 38 | ENDDO 39 | ENDDO 40 | ! 41 | END SUBROUTINE update_cr_dim 42 | ! 43 | !********************************************************************** 44 | ! 45 | END MODULE update_cr_dim_mod 46 | -------------------------------------------------------------------------------- /discus/prog/vtk_mod.f90: -------------------------------------------------------------------------------- 1 | module vtk_mod 2 | contains 3 | 4 | subroutine vtk_write () 5 | use diffuse_mod 6 | use crystal_mod 7 | use output_mod 8 | use errlist_mod 9 | use precision_mod 10 | USE support_mod 11 | implicit none 12 | real(kind=PREC_DP) :: dx,dy,dz 13 | 14 | dx=sqrt(out_vi(1,1)**2+out_vi(2,1)**2+out_vi(3,1)**2) 15 | dy=sqrt(out_vi(1,2)**2+out_vi(2,2)**2+out_vi(3,2)**2) 16 | dz=sqrt(out_vi(1,3)**2+out_vi(2,3)**2+out_vi(3,3)**2) 17 | 18 | call oeffne (2, outfile, 'unknown') 19 | if (ier_num.ne.0) return 20 | 21 | write(2,'(A)') '# vtk DataFile Version 3.0' 22 | write(2,'(A)') 'DISCUS OUTPUT' 23 | write(2,'(A)') 'ASCII' 24 | write(2,'(A)') 'DATASET STRUCTURED_POINTS' 25 | write(2,'(A,3(1X,I0))') 'DIMENSIONS',out_inc(1),out_inc(2),out_inc(3) 26 | write(2,'(A,3(1X,F0.4))') 'ORIGIN',out_eck(1,1),out_eck(2,1),out_eck(3,1) 27 | write(2,'(A,3(1X,F0.4))') 'SPACING',dx,dy,dz 28 | write(2,'(A,1X,I0)') 'POINT_DATA',out_inc(1)*out_inc(2)*out_inc(3) 29 | write(2,'(A)') 'SCALARS values float' 30 | write(2,'(A)') 'LOOKUP_TABLE default' 31 | write(2,'(E13.6E2)') dsi 32 | 33 | close(2) 34 | 35 | end subroutine vtk_write 36 | 37 | end module vtk_mod 38 | -------------------------------------------------------------------------------- /discus/prog/waves_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE waves_mod 2 | !+ 3 | ! This file contains variables for wave input 4 | !- 5 | use precision_mod 6 | ! 7 | SAVE 8 | ! 9 | INTEGER, PARAMETER :: WV_RAND = 1 10 | INTEGER, PARAMETER :: WV_FIX = 2 11 | ! 12 | INTEGER, PARAMETER :: WV_LONG = 1 13 | INTEGER, PARAMETER :: WV_TRANS = 2 14 | INTEGER, PARAMETER :: WV_DENS = 3 15 | INTEGER, PARAMETER :: WV_ROT = 4 16 | ! 17 | INTEGER, PARAMETER :: WV_SINUS = 1 18 | INTEGER, PARAMETER :: WV_BOX = 2 19 | INTEGER, PARAMETER :: WV_TRIANGLE = 3 20 | ! 21 | CHARACTER(LEN=4) :: wv_func = 'sinu' 22 | ! 23 | INTEGER :: WV_MAXSCAT = 1 24 | INTEGER :: WV_MAXSITE = 1 25 | ! 26 | INTEGER, DIMENSION(:), ALLOCATABLE :: wv_repl ! (0:WV_MAXSCAT) 27 | LOGICAL, DIMENSION(:), ALLOCATABLE :: wv_latom ! (0:WV_MAXSCAT) 28 | LOGICAL, DIMENSION(:), ALLOCATABLE :: wv_latom_rot ! (0:WV_MAXSCAT) 29 | LOGICAL, DIMENSION(:), ALLOCATABLE :: wv_lsite ! (0:WV_MAXSCAT) 30 | ! 31 | INTEGER :: wv_iwave = WV_LONG 32 | INTEGER :: wv_ifunc = WV_SINUS 33 | INTEGER :: wv_sel_prop(0:1) = 0 34 | INTEGER :: wv_phase_typ = WV_FIX 35 | REAL(kind=PREC_DP) :: wv_wave(3) = (/1.,0.,0./) 36 | REAL(kind=PREC_DP) :: wv_swing(3) = (/0.,1.,0./) 37 | REAL(kind=PREC_DP) :: wv_rot_uvw(3) = (/0.,0.,1./) 38 | REAL(kind=PREC_DP) :: wv_rot_orig(3) = 0.0 39 | REAL(kind=PREC_DP) :: wv_amp = 0.5 40 | REAL(kind=PREC_DP) :: wv_rlam =50.0 41 | REAL(kind=PREC_DP) :: wv_phase = 0.0 42 | REAL(kind=PREC_DP) :: wv_amp0 = 0.0 43 | REAL(kind=PREC_DP) :: wv_plow = 0.0 44 | REAL(kind=PREC_DP) :: wv_phigh = 0.0 45 | REAL(kind=PREC_DP) :: wv_asym = 0.5 46 | LOGICAL :: wv_sel_atom = .true. 47 | LOGICAL :: wv_lacoust = .true. 48 | LOGICAL :: wv_viceversa = .false. 49 | ! 50 | ! 51 | END MODULE waves_mod 52 | -------------------------------------------------------------------------------- /discus/prog/wyckoff_mod.f90: -------------------------------------------------------------------------------- 1 | module wyckoff_mod 2 | ! 3 | ! 4 | ! This file contains definitions for the symmetry operations 5 | ! and local site symmetry 6 | ! 7 | !*****7**************************************************************** 8 | ! 9 | use precision_mod 10 | ! 11 | save 12 | ! 13 | integer, PARAMETER :: SPC_MAX = 192 14 | integer, PARAMETER :: WYC_MAX = 48 15 | ! 16 | character(LEN=65) :: spc_char(1:SPC_MAX) ! Description of symmetry elements 17 | character(LEN=87) :: spc_xyz (1:SPC_MAX) ! Points on the symmetry elements 18 | integer :: spc_n ! Number in group 19 | real(kind=PREC_DP) :: spc_mat(4,4,1:SPC_MAX) ! The matrices 20 | real(kind=PREC_DP) :: spc_det (1:SPC_MAX) ! Determinants of symmetry elements 21 | real(kind=PREC_DP) :: spc_spur(1:SPC_MAX) ! Trace of symmetry elements 22 | real(kind=PREC_DP) :: spc_axis(3,1:SPC_MAX) ! Rotation axis or normal to mirror plane 23 | logical, dimension(1:SPC_MAX) :: spc_point ! Rotation matrix is part of point grup symmetry 24 | logical, dimension(1:SPC_MAX) :: spc_center ! Rotation matrix is Centering vector 25 | integer, dimension(1:SPC_MAX) :: spc_gen ! Rotation matrix is generator matrix 26 | integer, dimension(1:SPC_MAX, 1:SPC_MAX) :: spc_table ! Multiplication table 27 | ! 28 | integer :: wyc_n 29 | integer :: wyc_list(48) 30 | character(LEN=65) :: wyc_char(1:WYC_MAX) ! Description of symmetry elements 31 | character(LEN=87) :: wyc_xyz (1:WYC_MAX) ! Points on the symmetry elements 32 | real(kind=PREC_DP) :: wyc_mat(4,4,1:WYC_MAX) ! The matrices 33 | real(kind=PREC_DP) :: wyc_det (1:WYC_MAX) ! Determinants of symmetry elements 34 | real(kind=PREC_DP) :: wyc_spur(1:WYC_MAX) ! Trace of symmetry elements 35 | real(kind=PREC_DP) :: wyc_axis(3,1:WYC_MAX) ! Rotation axis or normal to mirror plane 36 | ! 37 | end module wyckoff_mod 38 | -------------------------------------------------------------------------------- /experi/prog/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | # EXPERI build 2 | 3 | include_directories(${DIFFUSE_SOURCE_DIR}/lib_f90) 4 | include_directories(${DIFFUSE_BINARY_DIR}/lib_f90) 5 | include_directories(${DIFFUSE_SOURCE_DIR}/discus/prog) 6 | include_directories(${DIFFUSE_BINARY_DIR}/discus/prog) 7 | include_directories(${DIFFUSE_SOURCE_DIR}/kuplot/prog) 8 | include_directories(${DIFFUSE_BINARY_DIR}/kuplot/prog) 9 | 10 | link_directories(${DIFFUSE_BINARY_DIR}/lib_f90) 11 | link_directories(${DIFFUSE_BINARY_DIR}/discus/prog) 12 | link_directories(${DIFFUSE_BINARY_DIR}/kuplot/prog) 13 | 14 | set (SOURCES_ALL experi_kdo.f90 experi_loop.f90 experi_reset.f90 15 | experi_setup.f90 experi_setup_sub.f90 16 | ) 17 | 18 | set (LIBS lib_f90 lib_f90c ${DIFFUSE_LIBS}) 19 | 20 | if (DIFFUSE_SHARED_LIB) 21 | add_library (experi_all SHARED ${SOURCES_ALL}) 22 | else (DIFFUSE_SHARED_LIB) 23 | add_library (experi_all ${SOURCES_ALL}) 24 | endif (DIFFUSE_SHARED_LIB) 25 | 26 | add_dependencies ( experi_all lib_f90 discus_all kuplot_all) 27 | 28 | add_custom_target(experihlp 29 | DEPENDS ${DIFFUSE_SOURCE_DIR}/experi/prog/appl_exp.hlp 30 | ${DIFFUSE_SOURCE_DIR}/lib_f90/lib_f90.hlp 31 | COMMAND cat ${DIFFUSE_SOURCE_DIR}/experi/prog/appl_exp.hlp 32 | ${DIFFUSE_SOURCE_DIR}/lib_f90/lib_f90.hlp > 33 | ${DIFFUSE_BINARY_DIR}/experi/prog/experi.hlp) 34 | 35 | add_dependencies(experi_all experihlp) 36 | if (DIFFUSE_SHARED_LIB) 37 | install (TARGETS experi_all DESTINATION lib) 38 | endif (DIFFUSE_SHARED_LIB) 39 | FILE(GLOB files "${DIFFUSE_SOURCE_DIR}/experi/prog/sysmac/*.mac") 40 | install (FILES ${files} DESTINATION share/experi) 41 | -------------------------------------------------------------------------------- /experi/prog/experi_reset.f90: -------------------------------------------------------------------------------- 1 | module experi_reset 2 | ! 3 | contains 4 | ! 5 | !******************************************************************************* 6 | ! 7 | subroutine experi_do_reset 8 | !- 9 | ! Reset to system start 10 | !+ 11 | continue ! At the moment ther's nothing to do 12 | ! 13 | end subroutine experi_do_reset 14 | ! 15 | !******************************************************************************* 16 | ! 17 | end module experi_reset 18 | -------------------------------------------------------------------------------- /experi/prog/experi_setup.f90: -------------------------------------------------------------------------------- 1 | module experi_setup_mod 2 | ! 3 | contains 4 | ! 5 | !******************************************************************************* 6 | ! 7 | subroutine experi_setup 8 | !- 9 | ! Make initial set up for EXPERI 10 | !+ 11 | ! 12 | use prompt_mod 13 | ! 14 | implicit none 15 | ! 16 | pname = 'experi' 17 | pname_cap = 'EXPERI' 18 | prompt = pname 19 | prompt_status = PROMPT_ON 20 | prompt_status_old = PROMPT_ON 21 | ! 22 | ! call experi_alloc_default 23 | ! call experi_initarrays 24 | ! 25 | end subroutine experi_setup 26 | ! 27 | !******************************************************************************* 28 | ! 29 | end module experi_setup_mod 30 | -------------------------------------------------------------------------------- /experi/prog/experi_setup_sub.f90: -------------------------------------------------------------------------------- 1 | module experi_setup_sub_mod 2 | ! 3 | contains 4 | ! 5 | !******************************************************************************* 6 | ! 7 | subroutine experi_set_sub 8 | !- 9 | ! Sets the specific EXPERI interfaces for routines that are refecenced in 10 | ! LIB_F90 by their generic names 11 | !+ 12 | ! 13 | use set_sub_generic_mod 14 | ! 15 | implicit none 16 | ! 17 | interface 18 | subroutine experi_mache_kdo (line, lend, length) 19 | ! 20 | character(len=*), intent(inout) :: line 21 | logical , intent( out) :: lend 22 | integer , intent(inout) :: length 23 | ! 24 | end subroutine experi_mache_kdo 25 | end interface 26 | ! 27 | p_mache_kdo => experi_mache_kdo 28 | 29 | end subroutine experi_set_sub 30 | ! 31 | !******************************************************************************* 32 | ! 33 | end module experi_setup_sub_mod 34 | -------------------------------------------------------------------------------- /finufft/AAA.README: -------------------------------------------------------------------------------- 1 | # 2 | # This is the essential part of project FINUFFT from 3 | # https://github.com/flatironinstitute/finufft 4 | # as needed for DISCUS 5 | # 6 | # During the actual installation, the current code is fetched from GITHUB 7 | # 8 | -------------------------------------------------------------------------------- /finufft/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | # 2 | # CMakeLists.txt file for finufft within DISCUS 3 | # R. Neder 2023_05_25 4 | # Uses the archive from "https://github.com/flatironinstitute/finufft/releases/tag/v*.*.*" 5 | # as subdirectory "finufft" within the project 6 | # 7 | # 8 | # The parent: "../ CMakeLists.txt" sets (among other things): 9 | # find_package(FFTW REQUIRED) 10 | # set (PROJECT_LIBS ${PROJECT_LIBS} ${FFTW_DOUBLE_LIB} ${FFTW_DOUBLE_OPENMP_LIB} ) 11 | # set (CMAKE_CXX_FLAGS "-O3 -fPIC -funroll-loops -march=native -fcx-limited-range -std=c++14 -fopenmp") 12 | # set (CMAKE_C_FLAGS "-O3 -fPIC") 13 | # add_subdirectory(finufft) 14 | # Here PROJECT_LIBS is a placeholder for other libraries that might be required by the project 15 | # 16 | # On MacOS the gnu compiler suite is installed into /usr/local/bin/ 17 | # and is enforced prior to creating the project with : 18 | # "export CC=/usr/local/bin/gcc-12" or whatever version 19 | # "export CXX=/usr/local/bin/g++-12" or whatever version 20 | # It seems to be important to do this prior to the first creation of the project or else 21 | # the cache will still have clang ... 22 | # 23 | # To ease installation of precompiled versions I prefer a static library 24 | 25 | set (CPPSOURCES src/finufft.cpp 26 | src/simpleinterfaces.cpp 27 | src/spreadinterp.cpp 28 | src/utils.cpp 29 | src/utils_precindep.cpp 30 | fortran/finufftfort.cpp 31 | contrib/legendre_rule_fast.cpp ) 32 | 33 | include_directories(include contrib ${FFTW_INCLUDE_DIRS}) 34 | 35 | if (DIFFUSE_SHARED_LIB) 36 | add_library (finufft_lib SHARED ${CPPSOURCES}) 37 | else (DIFFUSE_SHARED_LIB) 38 | add_library (finufft_lib ${CPPSOURCES}) 39 | endif (DIFFUSE_SHARED_LIB) 40 | #add_library (finufft_lib_s SHARED ${CPPSOURCES}) 41 | 42 | if (DIFFUSE_SHARED_LIB) 43 | install (TARGETS finufft_lib DESTINATION lib) 44 | endif (DIFFUSE_SHARED_LIB) 45 | -------------------------------------------------------------------------------- /finufft/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (C) 2017-2024 The Simons Foundation, Inc. - All Rights Reserved. 2 | 3 | See docs/ackn.rst for the list of code authors and contributors. 4 | 5 | ------ 6 | 7 | FINUFFT is licensed under the Apache License, Version 2.0 (the 8 | "License"); you may not use this file except in compliance with the 9 | License. You may obtain a copy of the License at 10 | 11 | http://www.apache.org/licenses/LICENSE-2.0 12 | 13 | Unless required by applicable law or agreed to in writing, software 14 | distributed under the License is distributed on an "AS IS" BASIS, 15 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 16 | See the License for the specific language governing permissions and 17 | limitations under the License. 18 | 19 | ------ 20 | 21 | Certain parts of this repository are contributed by others. 22 | For their license info, see: 23 | 24 | contrib/legendre_rule_fast.license 25 | fortran/cmcl_license.txt 26 | tutorial/utils/lgwt.m 27 | 28 | ------ 29 | 30 | If you find this library useful, or it helps you in creating software 31 | or publications, please let us know, and acknowledge that fact by citing our 32 | source repository: 33 | 34 | https://github.com/flatironinstitute/finufft 35 | 36 | and the corresponding journal articles (particularly the first for the CPU 37 | and/or the last for the GPU): 38 | 39 | A parallel non-uniform fast Fourier transform library based on an 40 | ``exponential of semicircle'' kernel. A. H. Barnett, J. F. Magland, 41 | and L. af Klinteberg. SIAM J. Sci. Comput. 41(5), C479-C504 (2019). 42 | 43 | Aliasing error of the $\exp (\beta \sqrt{1-z^2})$ kernel in the 44 | nonuniform fast Fourier transform. A. H. Barnett, 45 | Appl. Comput. Harmon. Anal. 51, 1-16 (2021). 46 | 47 | cuFINUFFT: a load-balanced GPU library for general-purpose nonuniform FFTs, 48 | Yu-hsuan Shih, Garrett Wright, Joakim Andén, Johannes Blaschke, and 49 | Alex H. Barnett. PDSEC2021 workshop of the IPDPS2021 conference. 50 | https://arxiv.org/abs/2102.08463 51 | -------------------------------------------------------------------------------- /finufft/contrib/legendre_rule_fast.h: -------------------------------------------------------------------------------- 1 | #ifndef GAUSSQUAD_H 2 | #define GAUSSQUAD_H 3 | 4 | namespace finufft { 5 | namespace quadrature { 6 | void legendre_compute_glr ( int n, double x[], double w[] ); 7 | } // namespace 8 | } // namespace 9 | 10 | #endif 11 | -------------------------------------------------------------------------------- /finufft/contrib/legendre_rule_fast.license: -------------------------------------------------------------------------------- 1 | LICENSE info for legendre_rule_fast.c ONLY: 2 | 3 | According to 4 | https://people.sc.fsu.edu/~jburkardt/c_src/legendre_rule_fast/legendre_rule_fast.html 5 | 6 | The computer code and data files described and made available on this web page are distributed under the GNU LGPL license: 7 | 8 | https://www.gnu.org/licenses/lgpl-3.0.en.html 9 | -------------------------------------------------------------------------------- /finufft/contrib/legendre_rule_fast.o: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tproffen/DiffuseCode/cafd7934ec4e96d3feadafb99c8d0ecce43de3c1/finufft/contrib/legendre_rule_fast.o -------------------------------------------------------------------------------- /finufft/fortran/cmcl_license.txt: -------------------------------------------------------------------------------- 1 | Below is the license applying to the original fortran drivers and direct 2 | evaluation routines modified in this directory. This license does not 3 | apply to the rest of FINUFFT. 4 | 5 | ------------- 6 | 7 | Copyright (c) 2009-2014, Leslie Greengard, June-Yub Lee and Zydrunas Gimbutas 8 | All rights reserved. 9 | 10 | Redistribution and use in source and binary forms, with or without 11 | modification, are permitted provided that the following conditions are met: 12 | 13 | 1. Redistributions of source code must retain the above copyright notice, this 14 | list of conditions and the following disclaimer. 15 | 2. Redistributions in binary form must reproduce the above copyright notice, 16 | this list of conditions and the following disclaimer in the documentation 17 | and/or other materials provided with the distribution. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 20 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 21 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR 23 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 24 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 25 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 26 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | 30 | The views and conclusions contained in the software and documentation are those 31 | of the authors and should not be interpreted as representing official policies, 32 | either expressed or implied, of the FreeBSD Project. 33 | -------------------------------------------------------------------------------- /finufft/include/finufft.fh: -------------------------------------------------------------------------------- 1 | c Fortran header recreating finufft_opts struct in fortran (f90 style). 2 | c This must be kept synchronized with finufft_opts.h, matching its order. 3 | c Also see ../fortran/finufftfort.cpp. Barnett 5/29/20. One prec 7/2/20. 4 | 5 | type finufft_opts 6 | integer debug, spread_debug,spread_sort,spread_kerevalmeth, 7 | $ spread_kerpad,chkbnds,fftw,modeord 8 | real*8 upsampfac 9 | integer spread_thread,maxbatchsize,showwarn,nthreads, 10 | $ spread_nthr_atomic,spread_max_sp_size 11 | end type 12 | -------------------------------------------------------------------------------- /finufft/include/finufft.h: -------------------------------------------------------------------------------- 1 | // Defines the public C++ and C compatible user interface to FINUFFT library. 2 | 3 | // This contains both single and double precision user-facing commands. 4 | // "macro-safe" rewrite, including the plan object, Barnett 5/21/22-6/7/22. 5 | // They will clobber any prior macros starting FINUFFT*, so in the lib/test 6 | // sources finufft.h must be included before defs.h 7 | 8 | 9 | /* Devnotes. 10 | A) Two precisions done by including the "either precision" headers twice. 11 | No use of the private headers for lib/test/example compilation is made. 12 | 13 | B) Good ways to debug this header --- 14 | 1) preprocessor output (gets the general idea the macros worked): 15 | cpp include/finufft.h -Iinclude 16 | cpp -dD include/finufft.h -Iinclude 17 | then https://gcc.gnu.org/onlinedocs/cpp/Preprocessor-Output.html 18 | 2) compile examples in both precs and C/C++, needed to catch typos: 19 | g++ examples/simple1d1.cpp -Iinclude -c 20 | g++ examples/simple1d1f.cpp -Iinclude -c 21 | gcc examples/simple1d1c.c -Iinclude -c 22 | gcc examples/simple1d1cf.c -Iinclude -c 23 | */ 24 | 25 | #ifndef FINUFFT_H 26 | #define FINUFFT_H 27 | 28 | // prec-indep stuff. both these are thus made public-facing 29 | #include 30 | #include 31 | 32 | // octave (mkoctfile) needs this otherwise it doesn't know what int64_t is! 33 | #include 34 | #define FINUFFT_BIGINT int64_t 35 | 36 | #ifndef __cplusplus 37 | #include // for bool type in C (needed for item in plan struct) 38 | #endif 39 | 40 | // this macro name has to be safe since exposed to user 41 | #define FINUFFT_SINGLE 42 | #include 43 | #undef FINUFFT_SINGLE 44 | // do it again for double-prec... 45 | #include 46 | 47 | // clean up any purely local defs that are not in finufft_eitherprec.h... 48 | #undef FINUFFT_BIGINT 49 | 50 | #endif // FINUFFT_H 51 | -------------------------------------------------------------------------------- /finufft/include/finufft/dirft.h: -------------------------------------------------------------------------------- 1 | #ifndef DIRFT_H 2 | #define DIRFT_H 3 | 4 | #include 5 | 6 | void dirft1d1(BIGINT nj,FLT* x,CPX* c,int isign,BIGINT ms, CPX* f); 7 | void dirft1d2(BIGINT nj,FLT* x,CPX* c,int iflag,BIGINT ms, CPX* f); 8 | void dirft1d3(BIGINT nj,FLT* x,CPX* c,int iflag,BIGINT nk, FLT* s, CPX* f); 9 | 10 | void dirft2d1(BIGINT nj,FLT* x,FLT *y,CPX* c,int iflag,BIGINT ms, BIGINT mt, CPX* f); 11 | void dirft2d2(BIGINT nj,FLT* x,FLT *y,CPX* c,int iflag,BIGINT ms, BIGINT mt, CPX* f); 12 | void dirft2d3(BIGINT nj,FLT* x,FLT *y,CPX* c,int iflag,BIGINT nk, FLT* s, FLT* t, CPX* f); 13 | 14 | void dirft3d1(BIGINT nj,FLT* x,FLT *y,FLT *z,CPX* c,int iflag,BIGINT ms, BIGINT mt, BIGINT mu, CPX* f); 15 | void dirft3d2(BIGINT nj,FLT* x,FLT *y,FLT *z,CPX* c,int iflag,BIGINT ms, BIGINT mt, BIGINT mu, CPX* f); 16 | void dirft3d3(BIGINT nj,FLT* x,FLT *y,FLT *z,CPX* c,int iflag,BIGINT nk, FLT* s, FLT* t, FLT *u, CPX* f); 17 | 18 | #endif 19 | -------------------------------------------------------------------------------- /finufft/include/finufft/fft.h: -------------------------------------------------------------------------------- 1 | #ifndef FINUFFT_INCLUDE_FINUFFT_FFT_H 2 | #define FINUFFT_INCLUDE_FINUFFT_FFT_H 3 | 4 | #ifdef FINUFFT_USE_DUCC0 5 | #include "ducc0/fft/fftnd_impl.h" 6 | #define FFTW_FORGET_WISDOM() // temporary hack since some tests call this unconditionally 7 | #define FFTW_CLEANUP() // temporary hack since some tests call this unconditionally 8 | #define FFTW_CLEANUP_THREADS() // temporary hack since some tests call this 9 | // unconditionally 10 | #else 11 | #include "fftw_defs.h" 12 | #endif 13 | #include 14 | 15 | int *gridsize_for_fft(FINUFFT_PLAN p); 16 | void do_fft(FINUFFT_PLAN p); 17 | 18 | #endif // FINUFFT_INCLUDE_FINUFFT_FFT_H 19 | -------------------------------------------------------------------------------- /finufft/include/finufft/fftw_defs.h: -------------------------------------------------------------------------------- 1 | #ifndef FFTW_DEFS_H 2 | #define FFTW_DEFS_H 3 | 4 | // Here we define typedefs and MACROS to switch between single and double 5 | // precision library compilation, which need different FFTW command symbols. 6 | // Barnett simplified via FFTWIFY, 6/7/22. 7 | 8 | #include // (after complex.h) needed so can typedef FFTW_CPX 9 | 10 | // precision-switching for names of interfaces of FFTW... 11 | #ifdef SINGLE 12 | // macro to prepend fftw_ (for doulbe) or fftwf_ (for single) to a string 13 | // without a space. The 2nd level of indirection is needed for safety, see: 14 | // https://isocpp.org/wiki/faq/misc-technical-issues#macros-with-token-pasting 15 | #define FFTWIFY_UNSAFE(x) fftwf_##x 16 | #else 17 | #define FFTWIFY_UNSAFE(x) fftw_##x 18 | #endif 19 | 20 | #define FFTWIFY(x) FFTWIFY_UNSAFE(x) 21 | // now use this tool (note we removed any typedefs in favor of macros): 22 | #define FFTW_CPX FFTWIFY(complex) 23 | #define FFTW_PLAN FFTWIFY(plan) 24 | #define FFTW_INIT FFTWIFY(init_threads) 25 | #define FFTW_PLAN_TH FFTWIFY(plan_with_nthreads) 26 | #define FFTW_ALLOC_RE FFTWIFY(alloc_real) 27 | #define FFTW_ALLOC_CPX FFTWIFY(alloc_complex) 28 | #define FFTW_PLAN_1D FFTWIFY(plan_dft_1d) 29 | #define FFTW_PLAN_2D FFTWIFY(plan_dft_2d) 30 | #define FFTW_PLAN_3D FFTWIFY(plan_dft_3d) 31 | #define FFTW_PLAN_MANY_DFT FFTWIFY(plan_many_dft) 32 | #define FFTW_EX FFTWIFY(execute) 33 | #define FFTW_DE FFTWIFY(destroy_plan) 34 | #define FFTW_FR FFTWIFY(free) 35 | #define FFTW_FORGET_WISDOM FFTWIFY(forget_wisdom) 36 | #define FFTW_CLEANUP FFTWIFY(cleanup) 37 | #define FFTW_CLEANUP_THREADS FFTWIFY(cleanup_threads) 38 | 39 | #ifdef FFTW_PLAN_SAFE 40 | #define FFTW_PLAN_SF() FFTWIFY(make_planner_thread_safe()) 41 | #else 42 | #define FFTW_PLAN_SF() 43 | #endif 44 | 45 | #endif // FFTW_DEFS_H 46 | -------------------------------------------------------------------------------- /finufft/include/finufft/test_defs.h: -------------------------------------------------------------------------------- 1 | // test-wide definitions and headers for use in ../test/ and ../perftest/ 2 | // Private to library; not for user use. 3 | // These switch precision based on if SINGLE is defined. 4 | 5 | #ifndef TEST_DEFS_H 6 | #define TEST_DEFS_H 7 | 8 | // TESTER SETTINGS... 9 | // how big a problem to check direct DFT for in 1D... 10 | #define TEST_BIGPROB 1e8 11 | // for omp rand filling 12 | #define TEST_RANDCHUNK 1000000 13 | 14 | // the public interface: since this clobbers FINUFFT* macros, must be included 15 | // *before* private defs.h... 16 | #include 17 | 18 | // convenient private finufft internals (must come after finufft.h) 19 | #include 20 | #include 21 | // prec-switching (via SINGLE) to set up FLT, CPX, BIGINT, FINUFFT1D1, etc... 22 | #include 23 | // since "many" (vector) tests need direct access to FFTW commands... 24 | #include 25 | 26 | // std stuff for tester src 27 | #include 28 | #include 29 | #include 30 | #include 31 | #include 32 | #include 33 | 34 | #endif // TEST_DEFS_H 35 | -------------------------------------------------------------------------------- /finufft/include/finufft/utils.h: -------------------------------------------------------------------------------- 1 | // Header for utils.cpp, a little library of low-level array stuff. 2 | // These are just the functions which depend on single/double precision (FLT) 3 | 4 | #ifndef UTILS_H 5 | #define UTILS_H 6 | 7 | #include "finufft/defs.h" 8 | 9 | namespace finufft { 10 | namespace utils { 11 | 12 | // ahb's low-level array helpers 13 | FLT relerrtwonorm(BIGINT n, CPX* a, CPX* b); 14 | FLT errtwonorm(BIGINT n, CPX* a, CPX* b); 15 | FLT twonorm(BIGINT n, CPX* a); 16 | FLT infnorm(BIGINT n, CPX* a); 17 | void arrayrange(BIGINT n, FLT* a, FLT *lo, FLT *hi); 18 | void indexedarrayrange(BIGINT n, BIGINT* i, FLT* a, FLT *lo, FLT *hi); 19 | void arraywidcen(BIGINT n, FLT* a, FLT *w, FLT *c); 20 | 21 | } // namespace 22 | } // namespace 23 | 24 | #endif // UTILS_H 25 | -------------------------------------------------------------------------------- /finufft/include/finufft/utils_precindep.h: -------------------------------------------------------------------------------- 1 | // Header for utils_precindep.cpp, a little library of array and timer stuff. 2 | // Only the precision-independent routines here (get compiled once) 3 | 4 | #ifndef UTILS_PRECINDEP_H 5 | #define UTILS_PRECINDEP_H 6 | 7 | #include "defs.h" 8 | // for CNTime... 9 | #include 10 | 11 | namespace finufft { 12 | namespace utils { 13 | 14 | BIGINT next235even(BIGINT n); 15 | 16 | // jfm's timer class 17 | class CNTime { 18 | public: 19 | void start(); 20 | double restart(); 21 | double elapsedsec(); 22 | private: 23 | struct timeval initial; 24 | }; 25 | 26 | // openmp helpers 27 | int get_num_threads_parallel_block(); 28 | 29 | } //namespace 30 | } //namespace 31 | 32 | // thread-safe rand number generator for Windows platform 33 | #ifdef _WIN32 34 | #include 35 | namespace finufft { 36 | namespace utils { 37 | int rand_r(unsigned int *seedp); 38 | } // namespace 39 | } // namespace 40 | #endif 41 | 42 | #endif // UTILS_PRECINDEP_H 43 | -------------------------------------------------------------------------------- /finufft/include/finufft_errors.h: -------------------------------------------------------------------------------- 1 | #ifndef FINUFFT_ERRORS_H 2 | #define FINUFFT_ERRORS_H 3 | 4 | // ---------- Global error/warning output codes for the library --------------- 5 | // All documentation is at ../docs/errors.rst (not here): 6 | #define FINUFFT_WARN_EPS_TOO_SMALL 1 7 | #define FINUFFT_ERR_MAXNALLOC 2 8 | #define FINUFFT_ERR_SPREAD_BOX_SMALL 3 9 | #define FINUFFT_ERR_SPREAD_PTS_OUT_RANGE 4 // DEPRECATED 10 | #define FINUFFT_ERR_SPREAD_ALLOC 5 11 | #define FINUFFT_ERR_SPREAD_DIR 6 12 | #define FINUFFT_ERR_UPSAMPFAC_TOO_SMALL 7 13 | #define FINUFFT_ERR_HORNER_WRONG_BETA 8 14 | #define FINUFFT_ERR_NTRANS_NOTVALID 9 15 | #define FINUFFT_ERR_TYPE_NOTVALID 10 16 | #define FINUFFT_ERR_ALLOC 11 17 | #define FINUFFT_ERR_DIM_NOTVALID 12 18 | #define FINUFFT_ERR_SPREAD_THREAD_NOTVALID 13 19 | #define FINUFFT_ERR_NDATA_NOTVALID 14 20 | #define FINUFFT_ERR_CUDA_FAILURE 15 21 | #define FINUFFT_ERR_PLAN_NOTVALID 16 22 | #define FINUFFT_ERR_METHOD_NOTVALID 17 23 | #define FINUFFT_ERR_BINSIZE_NOTVALID 18 24 | #define FINUFFT_ERR_INSUFFICIENT_SHMEM 19 25 | #define FINUFFT_ERR_NUM_NU_PTS_INVALID 20 26 | #endif 27 | -------------------------------------------------------------------------------- /finufft/include/finufft_mod.f90: -------------------------------------------------------------------------------- 1 | module finufft_mod 2 | ! Fortran header recreating finufft_opts struct in fortran (f90 style) 3 | ! Module version. Neder 1/20/23. 4 | ! This must be kept synchronized with finufft_opts.h, matching its order. 5 | ! Also see ../fortran/finufftfort.cpp. Barnett 5/29/20. One prec 7/2/20. 6 | ! Relies on "use ISO_C_BINDING" in the fortran module 7 | use iso_c_binding 8 | ! 9 | type finufft_opts 10 | integer(kind=C_INT) :: debug, spread_debug,spread_sort,spread_kerevalmeth 11 | integer(kind=C_INT) :: spread_kerpad,chkbnds,fftw,modeord 12 | real(kind=C_DOUBLE) :: upsampfac 13 | integer(kind=C_INT) :: spread_thread,maxbatchsize,showwarn,nthreads 14 | integer(kind=C_INT) :: spread_nthr_atomic,spread_max_sp_size 15 | end type 16 | ! 17 | end module finufft_mod 18 | -------------------------------------------------------------------------------- /finufft/include/finufft_spread_opts.h: -------------------------------------------------------------------------------- 1 | #ifndef FINUFFT_SPREAD_OPTS_H 2 | #define FINUFFT_SPREAD_OPTS_H 3 | 4 | // C-compatible options struct for spread/interpolation within FINUFFT 5 | 6 | // Notes: 1) Has to be part of public-facing 7 | // headers since finufft_plan has an instance of this spread_opts struct. 8 | // 2) Deliberately uses fixed types (no macro precision-switching). 9 | 10 | typedef struct finufft_spread_opts { 11 | // See spreadinterp:setup_spreader for default values of the following fields. 12 | // This is the main documentation for these options... 13 | int nspread; // w, the kernel width in grid pts 14 | int spread_direction; // 1 means spread NU->U, 2 means interpolate U->NU 15 | int pirange; // 0: NU periodic domain is [0,N), 1: domain [-pi,pi) 16 | int chkbnds; // 0: don't check NU pts in 3-period range; 1: do 17 | int sort; // 0: don't sort NU pts, 1: do, 2: heuristic choice 18 | int kerevalmeth; // 0: direct exp(sqrt()), or 1: Horner ppval, fastest 19 | int kerpad; // 0: no pad w to mult of 4, 1: do pad 20 | // (this helps SIMD for kerevalmeth=0, eg on i7). 21 | int nthreads; // # threads for spreadinterp (0: use max avail) 22 | int sort_threads; // # threads for sort (0: auto-choice up to nthreads) 23 | int max_subproblem_size; // # pts per t1 subprob; sets extra RAM per thread 24 | int flags; // binary flags for timing only (may give wrong ans 25 | // if changed from 0!). See spreadinterp.h 26 | int debug; // 0: silent, 1: small text output, 2: verbose 27 | int atomic_threshold; // num threads before switching spreadSorted to using atomic ops 28 | double upsampfac; // sigma, upsampling factor 29 | // ES kernel specific consts for eval. No longer FLT, to avoid name clash... 30 | double ES_beta; 31 | double ES_halfwidth; 32 | double ES_c; 33 | } finufft_spread_opts; 34 | 35 | #endif // FINUFFT_SPREAD_OPTS_H 36 | -------------------------------------------------------------------------------- /kuplot/prog/fit_params_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE fit_params_mod 2 | ! 3 | USE kuplot_config 4 | USE kuplot_mod 5 | ! 6 | use precision_mod 7 | ! 8 | INTEGER :: iwert 9 | REAL(kind=PREC_DP), DIMENSION(MAXPARA) :: dff 10 | REAL(kind=PREC_DP) :: ff 11 | 12 | END MODULE fit_params_mod 13 | -------------------------------------------------------------------------------- /kuplot/prog/fit_set_sub_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE fit_set_sub_mod 2 | ! 3 | CONTAINS 4 | ! 5 | !******************************************************************************* 6 | ! 7 | SUBROUTINE fit_set_sub 8 | ! 9 | USE set_sub_generic_mod 10 | ! 11 | IMPLICIT NONE 12 | ! 13 | INTERFACE 14 | SUBROUTINE fit_mache_kdo (line, lend, length) 15 | ! 16 | CHARACTER (LEN= * ), INTENT(INOUT) :: line 17 | LOGICAL , INTENT( OUT) :: lend 18 | INTEGER , INTENT(INOUT) :: length 19 | ! 20 | END SUBROUTINE fit_mache_kdo 21 | END INTERFACE 22 | ! 23 | p_mache_kdo => fit_mache_kdo 24 | ! 25 | END SUBROUTINE fit_set_sub 26 | ! 27 | !******************************************************************************* 28 | ! 29 | END MODULE fit_set_sub_mod 30 | -------------------------------------------------------------------------------- /kuplot/prog/kuplot.f90: -------------------------------------------------------------------------------- 1 | PROGRAM kuplot 2 | ! 3 | USE kuplot_setup_mod 4 | USE kuplot_loop_mod 5 | USE variable_mod 6 | IMPLICIT none 7 | ! 8 | LOGICAL, PARAMETER :: standalone = .true. 9 | EXTERNAL :: kuplot_sigint 10 | !*****7***************************************************************** 11 | ! This is the universal plot program KUPLOT. It sets up most 12 | ! variables and calls the loop interpreting the commands. 13 | !*****7***************************************************************** 14 | ! 15 | ! 16 | ! 17 | CALL kuplot_setup (standalone) 18 | CALL kuplot_set_sub 19 | CALL SIGNAL(2, kuplot_sigint) 20 | var_val(VAR_PROGRAM) = var_val(VAR_KUPLOT) 21 | var_val(VAR_STATE) = var_val(VAR_IS_TOP) 22 | CALL kuplot_loop 23 | ! 24 | ! 25 | END PROGRAM kuplot 26 | -------------------------------------------------------------------------------- /kuplot/prog/kuplot_2dmap_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE kuplot_2dm_mod 2 | ! 3 | USE precision_mod 4 | ! 5 | PUBLIC 6 | ! 7 | INTEGER, PARAMETER :: K2DM_XY = 1 8 | INTEGER, PARAMETER :: K2DM_CSV = 2 9 | INTEGER, PARAMETER :: K2DM_YF_LOOP = 1 10 | INTEGER, PARAMETER :: K2DM_YF_INC = 2 11 | INTEGER, PARAMETER :: K2DM_YF_FUNC = 3 12 | INTEGER, PARAMETER :: K2DM_ERROR = -1 13 | INTEGER, PARAMETER :: K2DM_BLANK = 0 14 | INTEGER, PARAMETER :: K2DM_IGNORE = 1 15 | ! 16 | CHARACTER(LEN=4) :: k2dm_ctype = ' ' 17 | CHARACTER(LEN=PREC_STRING) :: k2dm_line = ' ' 18 | CHARACTER(LEN=PREC_STRING) :: k2dm_line_b = ' ' 19 | CHARACTER(LEN=PREC_STRING) :: k2dm_line_yf = ' ' 20 | INTEGER :: k2dm_type = 0 21 | INTEGER :: k2dm_miss = -1 22 | LOGICAL :: k2dm_miss_set = .FALSE. 23 | INTEGER, DIMENSION(0:2) :: k2dm_start = 0 24 | INTEGER, DIMENSION(0:2) :: k2dm_end = 0 25 | INTEGER, DIMENSION(0:2) :: k2dm_step = 0 26 | LOGICAL :: k2dm_lxmin = .TRUE. 27 | LOGICAL :: k2dm_lxmax = .TRUE. 28 | REAL :: k2dm_scale = 1.0 29 | REAL :: k2dm_xmin = 0.0 30 | REAL :: k2dm_xmax = 0.0 31 | INTEGER :: k2dm_type_yf = K2DM_YF_LOOP 32 | ! 33 | END MODULE kuplot_2dm_mod 34 | -------------------------------------------------------------------------------- /kuplot/prog/kuplot_3dmap_draw.f90: -------------------------------------------------------------------------------- 1 | MODULE kuplot_3dm_draw 2 | ! 3 | IMPLICIT NONE 4 | ! 5 | CONTAINS 6 | ! 7 | !******************************************************************************* 8 | ! 9 | SUBROUTINE kuplot_draw_3d_static(ik) 10 | ! 11 | ! Draws a 3D rendering of a bitmap 12 | ! 13 | USE kuplot_config 14 | USE kuplot_mod 15 | USE kuplot_3dm_mod 16 | ! 17 | IMPLICIT NONE 18 | ! 19 | INTEGER, INTENT(in) :: ik 20 | ! 21 | !REAL :: zzmin, zzmax ! min max z values as of hlin command 22 | ! 23 | END SUBROUTINE kuplot_draw_3d_static 24 | ! 25 | !******************************************************************************* 26 | ! 27 | END MODULE kuplot_3dm_draw 28 | -------------------------------------------------------------------------------- /kuplot/prog/kuplot_3dmap_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE kuplot_3dm_mod 2 | ! 3 | USE precision_mod 4 | ! 5 | PUBLIC 6 | ! 7 | INTEGER :: k3dm_ik = 0 8 | LOGICAL :: k3dm_lflat = .TRUE. 9 | REAL :: k3dm_phi = 0.0 10 | REAL :: k3dm_rho = 0.0 11 | ! 12 | INTEGER, PARAMETER :: K3DM_XY = 1 13 | INTEGER, PARAMETER :: K3DM_CSV = 2 14 | INTEGER, PARAMETER :: K3DM_YF_LOOP = 1 15 | INTEGER, PARAMETER :: K3DM_YF_INC = 2 16 | INTEGER, PARAMETER :: K3DM_YF_FUNC = 3 17 | INTEGER, PARAMETER :: K3DM_ERROR = -1 18 | INTEGER, PARAMETER :: K3DM_BLANK = 0 19 | INTEGER, PARAMETER :: K3DM_IGNORE = 1 20 | ! 21 | CHARACTER(LEN=4) :: k3dm_ctype = ' ' 22 | CHARACTER(LEN=PREC_STRING) :: k3dm_line = ' ' 23 | CHARACTER(LEN=PREC_STRING) :: k3dm_line_b = ' ' 24 | CHARACTER(LEN=PREC_STRING) :: k3dm_line_yf = ' ' 25 | 26 | INTEGER :: k3dm_type = 0 27 | INTEGER :: k3dm_miss = -1 28 | INTEGER :: k3dm_start = 0 29 | INTEGER :: k3dm_end = 0 30 | INTEGER :: k3dm_step = 0 31 | LOGICAL :: k3dm_lxmin = .TRUE. 32 | LOGICAL :: k3dm_lxmax = .TRUE. 33 | REAL :: k3dm_scale = 1.0 34 | REAL :: k3dm_xmin = 0.0 35 | REAL :: k3dm_xmax = 0.0 36 | INTEGER :: k3dm_type_yf = K3DM_YF_LOOP 37 | ! 38 | END MODULE kuplot_3dm_mod 39 | -------------------------------------------------------------------------------- /kuplot/prog/kuplot_branch.f90: -------------------------------------------------------------------------------- 1 | SUBROUTINE kuplot_branch(zeile, length, lreset, lloop) 2 | ! 3 | ! Specific KUPLOT Version of a branch subroutine 4 | ! Call DISCUS via system 5 | ! 6 | USE errlist_mod 7 | ! 8 | IMPLICIT NONE 9 | ! 10 | CHARACTER (LEN=*), INTENT(IN) :: zeile 11 | INTEGER , INTENT(IN) :: length 12 | LOGICAL , INTENT(IN) :: lreset 13 | integer , INTENT(IN) :: lloop 14 | ! 15 | ier_num = -7 16 | ier_typ = ER_COMM 17 | ! 18 | END SUBROUTINE kuplot_branch 19 | -------------------------------------------------------------------------------- /kuplot/prog/kuplot_setup_sub.f90: -------------------------------------------------------------------------------- 1 | MODULE kuplot_setup_sub_mod 2 | ! 3 | CONTAINS 4 | ! 5 | !*****7***************************************************************** 6 | ! 7 | SUBROUTINE kuplot_set_sub 8 | ! 9 | ! Sets the specific DIFFEV interfaces four routines that are refecenced in 10 | ! LIB_F90 by their generic names 11 | ! 12 | use kuplot_errlist_mod 13 | use kuplot_update_mod 14 | USE set_sub_generic_mod 15 | USE prompt_mod 16 | ! 17 | INTERFACE 18 | SUBROUTINE kuplot_mache_kdo (line, lend, length) 19 | ! 20 | CHARACTER (LEN= * ), INTENT(INOUT) :: line 21 | LOGICAL , INTENT( OUT) :: lend 22 | INTEGER , INTENT(INOUT) :: length 23 | ! 24 | END SUBROUTINE kuplot_mache_kdo 25 | END INTERFACE 26 | ! 27 | INTERFACE 28 | SUBROUTINE kuplot_branch(zeile, length, lreset, lloop) 29 | ! 30 | CHARACTER (LEN=*), INTENT(IN) :: zeile 31 | INTEGER , INTENT(IN) :: length 32 | LOGICAL , INTENT(IN) :: lreset 33 | integer , INTENT(IN) :: lloop 34 | ! 35 | END SUBROUTINE kuplot_branch 36 | END INTERFACE 37 | ! 38 | INTERFACE 39 | SUBROUTINE kuplot_top(zeile) 40 | ! 41 | CHARACTER (LEN=*), INTENT(IN) :: zeile 42 | END SUBROUTINE kuplot_top 43 | END INTERFACE 44 | ! 45 | p_mache_kdo => kuplot_mache_kdo 46 | p_errlist_appl => kuplot_errlist_appl 47 | p_ersetz_para => kuplot_ersetz_para 48 | p_upd_para => kuplot_upd_para 49 | p_calc_intr_spec => kuplot_calc_intr_spec 50 | p_calc_intr_log_spec=> kuplot_calc_intr_log_spec 51 | p_validate_var_spec => kuplot_validate_var_spec 52 | p_branch => kuplot_branch 53 | !p_loop_mpi => dummy_loop_mpi 54 | p_get_var_type => kuplot_get_var_type 55 | IF(lstandalone) THEN 56 | p_top => kuplot_top 57 | ENDIF 58 | ! 59 | END SUBROUTINE kuplot_set_sub 60 | ! 61 | !*****7***************************************************************** 62 | ! 63 | END MODULE kuplot_setup_sub_mod 64 | -------------------------------------------------------------------------------- /kuplot/prog/kuplot_top.f90: -------------------------------------------------------------------------------- 1 | SUBROUTINE kuplot_top(zeile) 2 | ! 3 | ! Specific KUPLOT Version of a branch subroutine 4 | ! Call DISCUS via system 5 | ! 6 | USE errlist_mod 7 | ! 8 | IMPLICIT NONE 9 | ! 10 | CHARACTER (LEN=*), INTENT(IN) :: zeile 11 | ! 12 | ier_num = -7 13 | ier_typ = ER_COMM 14 | ! 15 | END SUBROUTINE kuplot_top 16 | -------------------------------------------------------------------------------- /kuplot/prog/nexus.inc: -------------------------------------------------------------------------------- 1 | !+ 2 | ! Variables for NeXus file handling 3 | !- 4 | CHARACTER*200 run_title,run_stime,run_etime 5 | CHARACTER*200 nxs_fname 6 | INTEGER*4 run_iexp,run_irun 7 | INTEGER*4 nxs_id(NXHANDLESIZE) 8 | LOGICAL nxs_open 9 | ! 10 | COMMON /nxsi/ run_title,run_stime,run_etime, & 11 | & run_iexp,run_irun 12 | COMMON /nxs/ nxs_fname,nxs_id,nxs_open 13 | 14 | -------------------------------------------------------------------------------- /kuplot/prog/sysmac/gs-sub.mac: -------------------------------------------------------------------------------- 1 | #---------------------------------------------- 2 | # 3 | # $Id: gs-sub.mac,v 1.1.1.1 2012/06/09 16:19:02 rbneder Exp $ 4 | # 5 | # Macro to subtract two GSAS files 6 | #---------------------------------------------- 7 | # $1: File 1 (no .gsa extension) 8 | # $2: File 2 (no .gsa extension) 9 | # $3: Smoothing of Run 2 10 | # $4: Title for output file 11 | #---------------------------------------------- 12 | # 13 | reset 14 | # 15 | if ($0.ne.4) then 16 | stop 17 | endif 18 | # 19 | load gs,$1.gsa,all 20 | # 21 | i[10]=n[1] 22 | # 23 | do i[1]=1,i[10] 24 | load gs,$2.gsa,i[1] 25 | if ($3.gt.1) then 26 | smooth n[1],$3 27 | endif 28 | do i[2]=1,np[i[10]] 29 | y[i[1],i[2]]=y[i[1],i[2]]-y[n[1],i[2]] 30 | enddo 31 | n[1]=n[1]-1 32 | enddo 33 | # 34 | tit1 $4 35 | # 36 | dsav gsas,$1_$2.gsa 37 | # 38 | -------------------------------------------------------------------------------- /kuplot/prog/sysmac/systest.mac: -------------------------------------------------------------------------------- 1 | set prompt,off,on,save 2 | # 3 | # $Id: systest.mac,v 1.1.1.1 2012/06/09 16:19:02 rbneder Exp $ 4 | # 5 | echo "KUPLOT system macros seem to work ..." 6 | set prompt,old 7 | -------------------------------------------------------------------------------- /lib_f90/FCreadline.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | # 8 | /* -------------------------------------------------------------------------- */ 9 | void FCreadline(int len, char *myline, char prompt[]){ 10 | /* 11 | @(#)FCreadline.sh return line from readline(3c) to Fortran. John S. Urban, 20100323 12 | 13 | Simple procedure that uses readline in "normal" (i.e. non-callback) mode. 14 | 15 | len -- number of characters in argument "myline" 16 | myline -- Fortran CHARACTER variable to recieve the line read by readline(3c) 17 | prompt -- prompt string to preceed read 18 | 19 | */ 20 | char *line; /* readline(3c) will return the read line to this pointer */ 21 | int i; /* counter for padding returned line with spaces */ 22 | 23 | using_history(); 24 | line=readline(prompt); /* use readline(3c) to read a line of input in edit mode */ 25 | if (line == NULL) { 26 | line = strdup("exit"); 27 | } 28 | if(strlen(line) >0) { /* save non-zero strings only */ 29 | add_history(line); 30 | } 31 | 32 | strncpy(myline,line,len); /* copy line returned by readline(3c) to MYLINE up to length of MYLINE */ 33 | 34 | for(i=strlen(line);i0) { 47 | add_history(myline); 48 | } 49 | } 50 | -------------------------------------------------------------------------------- /lib_f90/charact_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE charact_mod 2 | !+ 3 | ! Parameter definitions for constant strings of ASCII equivalents 4 | !- 5 | IMPLICIT NONE 6 | PUBLIC 7 | SAVE 8 | ! 9 | CHARACTER(LEN=1), PARAMETER :: TAB = ACHAR(9) 10 | ! 11 | INTEGER, PARAMETER :: a = IACHAR('a') 12 | INTEGER, PARAMETER :: z = IACHAR('z') 13 | INTEGER, PARAMETER :: aa = IACHAR('A') 14 | INTEGER, PARAMETER :: zz = IACHAR('Z') 15 | ! 16 | INTEGER, PARAMETER :: zero = IACHAR('0') 17 | INTEGER, PARAMETER :: nine = IACHAR('9') 18 | ! 19 | INTEGER, PARAMETER :: period = IACHAR('.') 20 | ! 21 | INTEGER, PARAMETER :: u = IACHAR('_') 22 | INTEGER, PARAMETER :: blank1 = IACHAR(' ') 23 | ! 24 | END MODULE charact_mod 25 | -------------------------------------------------------------------------------- /lib_f90/constants_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE constants_mod 2 | ! 3 | IMPLICIT NONE 4 | SAVE 5 | ! 6 | INTEGER, PARAMETER :: IS_UNKNOWN = -1 7 | INTEGER, PARAMETER :: IS_SCAL = 0 8 | INTEGER, PARAMETER :: IS_VEC = 1 9 | INTEGER, PARAMETER :: IS_ARR = 2 10 | ! 11 | INTEGER, PARAMETER :: IS_INTE = 0 12 | INTEGER, PARAMETER :: IS_REAL = 1 13 | INTEGER, PARAMETER :: IS_CHAR = 2 14 | INTEGER, PARAMETER :: IS_EXPR = 3 15 | ! 16 | INTEGER, PARAMETER :: IS_WRITE = 0 ! Read/write 17 | INTEGER, PARAMETER :: IS_READ = 1 ! Read only 18 | ! 19 | END MODULE constants_mod 20 | -------------------------------------------------------------------------------- /lib_f90/count_col_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE count_col_mod 2 | ! 3 | private 4 | ! 5 | public count_col 6 | ! 7 | CONTAINS 8 | ! 9 | !*****7*************************************************************** 10 | SUBROUTINE count_col (zeile, ianz) 11 | !+ 12 | ! This subroutine counts the number of columns of string 'zeile' 13 | !- 14 | USE lib_length 15 | USE prompt_mod 16 | ! 17 | IMPLICIT NONE 18 | ! 19 | CHARACTER (LEN=* ), INTENT(IN) :: zeile 20 | INTEGER , INTENT(INOUT) :: ianz 21 | ! 22 | INTEGER :: i 23 | LOGICAL :: ein 24 | ! 25 | ! 26 | ianz = 0 27 | ein = .false. 28 | ! 29 | DO i = 1, len_str (zeile) 30 | IF (zeile (i:i) /= ' ') THEN 31 | ein = .true. 32 | ELSEIF (zeile (i:i) == ' '.AND.ein) THEN 33 | ein = .false. 34 | ianz = ianz + 1 35 | ENDIF 36 | ENDDO 37 | ! 38 | IF (ein) ianz = ianz + 1 39 | ! 40 | END SUBROUTINE count_col 41 | ! 42 | !*****7**************************************************************** 43 | ! 44 | END MODULE count_col_mod 45 | -------------------------------------------------------------------------------- /lib_f90/csup.c: -------------------------------------------------------------------------------- 1 | /*******************************************************************/ 2 | /* */ 3 | /* Various helper routines in C */ 4 | /* */ 5 | /*******************************************************************/ 6 | 7 | #ifdef WIN32 8 | #include "win32-glob.h" 9 | #else 10 | #include 11 | #endif 12 | 13 | #include 14 | #include 15 | #include 16 | 17 | glob_t globbuf; 18 | 19 | /*******************************************************************/ 20 | /* Routines to glob files */ 21 | /* integer ifiles(mask,lm): Find files matching "mask" */ 22 | /* subroutine getfile(fname,il,i): Get filename number "i" */ 23 | /* subroutine freefiles() : Free space alloc. by ifiles */ 24 | /*******************************************************************/ 25 | int ifiles_ (unsigned char *mask, int *l) 26 | { 27 | char *cmask; 28 | 29 | cmask=malloc((int)*l+1); 30 | strncpy(cmask,(char *)mask,(int)*l); 31 | cmask[*l]='\0'; 32 | 33 | #ifdef WIN32 34 | glob(cmask, 0, NULL, &globbuf); 35 | #else 36 | globbuf.gl_offs = 1; 37 | glob(cmask, GLOB_DOOFFS, NULL, &globbuf); 38 | #endif 39 | return globbuf.gl_pathc; 40 | } 41 | 42 | void getfile_ (unsigned char *file, int *l, int *i) 43 | { 44 | int len; 45 | 46 | len=strlen(globbuf.gl_pathv[*i]); 47 | memcpy(file,globbuf.gl_pathv[*i],len); 48 | } 49 | 50 | void freefiles_() 51 | { 52 | globfree(&globbuf); 53 | } 54 | -------------------------------------------------------------------------------- /lib_f90/data_types.f90: -------------------------------------------------------------------------------- 1 | module lib_data_types_mod 2 | ! 3 | use precision_mod 4 | ! 5 | public 6 | ! 7 | integer, parameter :: H5_UNKNOWN = 0 8 | integer, parameter :: H5_1D_GEN = 1 ! Generic 1-D line 9 | integer, parameter :: H5_2D_GEN = 2 ! Generic 2-D plane 10 | integer, parameter :: H5_3D_GEN = 3 ! Generic 3-D plane 11 | integer, parameter :: H5_1D_RECI = 4 ! Reciprocal 1-Line 12 | integer, parameter :: H5_2D_RECI = 5 ! Reciprocal 2-D plane 13 | integer, parameter :: H5_3D_RECI = 6 ! Reciprocal 3-D plane 14 | integer, parameter :: H5_1D_DIRECT = 7 ! Direct 1-Line 15 | integer, parameter :: H5_2D_DIRECT = 8 ! Direct 2-D plane 16 | integer, parameter :: H5_3D_DIRECT = 9 ! Direct 3-D plane 17 | integer, parameter :: H5_BRAGG_I = 10 ! Bragg data hkl, inte, sigma 18 | integer, parameter :: H5_BRAGG_SYM = 11 ! Bragg data hkl, inte, sigma, Symmetry averaged 19 | integer, parameter :: H5_POWDER_I = 12 ! Powder diffraction Intensity 20 | integer, parameter :: H5_POWDER_SQ = 13 ! Powder diffraction Intensity 21 | integer, parameter :: H5_POWDER_FQ = 14 ! Powder diffraction Intensity 22 | ! 23 | end module lib_data_types_mod 24 | -------------------------------------------------------------------------------- /lib_f90/date.inc.template: -------------------------------------------------------------------------------- 1 | ! date.inc 2 | ! Created by cmake .. 3 | ! 4 | character(35) cdate 5 | parameter (cdate='@BUILD_DATE@') 6 | character(10) aktuell 7 | parameter (aktuell='@DIFFUSE_VERSION_MAJOR@.@DIFFUSE_VERSION_MINOR@.@DIFFUSE_VERSION_PATCH@') 8 | CHARACTER(LEN=10) cdebug 9 | PARAMETER (cdebug='@DEBUG@') 10 | -------------------------------------------------------------------------------- /lib_f90/debug.h: -------------------------------------------------------------------------------- 1 | 2 | /* 3 | DEBUG.H 4 | Fortran debugging output tools 5 | */ 6 | 7 | #define TRACE_MACROS 1 8 | #define DEBUG 0 9 | 10 | #if TRACE_MACROS==1 11 | 12 | #define MACRO(token) print *, "MACRO: ", token 13 | 14 | #else 15 | 16 | #define MACRO(token) 17 | 18 | #endif 19 | 20 | #if DEBUG==1 21 | 22 | /** Show a message */ 23 | #define MSG(message) print *, "F90: ", message 24 | /** Show a variable */ 25 | #define VAR(variable) print *, "F90: ", "variable: ", variable 26 | /** Show a vector */ 27 | #define VEC(variable) print *, "F90: ", "variable:", achar(10), \ 28 | variable, achar(10), " --" 29 | 30 | #else 31 | 32 | #define MSG(message) 33 | #define VAR(variable) 34 | #define VEC(variable) 35 | 36 | #endif 37 | -------------------------------------------------------------------------------- /lib_f90/debug_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE debug_mod 2 | !+ 3 | ! Contains debugging variable 4 | !- 5 | IMPLICIT NONE 6 | PUBLIC 7 | SAVE 8 | ! 9 | LOGICAL :: dbg = .false. 10 | ! 11 | END MODULE debug_mod 12 | -------------------------------------------------------------------------------- /lib_f90/doact_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE doact_mod 2 | !+ 3 | ! Variables used to indicate whether do-loop 4 | ! of if block is active. 5 | !- 6 | IMPLICIT NONE 7 | PUBLIC 8 | SAVE 9 | ! 10 | LOGICAL :: lblock 11 | LOGICAL :: lblock_dbg 12 | LOGICAL :: lblock_read 13 | LOGICAL :: lmacro_close = .TRUE. 14 | ! 15 | ! 16 | END MODULE doact_mod 17 | -------------------------------------------------------------------------------- /lib_f90/doexec_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE doexec_mod 2 | !+ 3 | ! Variablves used during do and if execution 4 | !- 5 | USE doloop_mod 6 | USE precision_mod 7 | ! 8 | IMPLICIT NONE 9 | PUBLIC 10 | SAVE 11 | ! 12 | CHARACTER (LEN=PREC_STRING), DIMENSION(0:MAXCOM,0:MAXLEV) :: do_comm !(0:MAXCOM,0:MAXLEV) 13 | CHARACTER (LEN=PREC_STRING), DIMENSION(0:MAXCOM,0:MAXLEV) :: do_macro !(0:MAXCOM,0:MAXLEV) 14 | 15 | INTEGER , DIMENSION(0:MAXCOM,0:MAXLEV) :: do_leng ! (0:MAXCOM,0:MAXLEV) 16 | INTEGER :: level 17 | INTEGER , DIMENSION( 0:MAXLEV) :: nlevel ! (0:MAXLEV) 18 | INTEGER , DIMENSION( 0:MAXLEV) :: ilevel ! (0:MAXLEV) 19 | INTEGER , DIMENSION( 0:MAXLEV) :: jlevel ! (0:MAXLEV) 20 | INTEGER , DIMENSION( 0:MAXLEV) :: jump ! (0:MAXLEV) 21 | LOGICAL , DIMENSION( 0:MAXLEV) :: ltest ! (0:MAXLEV) 22 | ! 23 | INTEGER :: nlevel_mpi 24 | INTEGER :: level_mpi 25 | ! 26 | END MODULE doexec_mod 27 | -------------------------------------------------------------------------------- /lib_f90/doloop_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE doloop_mod 2 | !+ 3 | ! This file contains Variable definitions for do loop's, if's 4 | !- 5 | USE precision_mod 6 | ! 7 | IMPLICIT NONE 8 | ! 9 | PUBLIC 10 | SAVE 11 | ! 12 | INTEGER, PARAMETER :: MAXLEV = 20 13 | INTEGER, PARAMETER :: MAXCOM = 2000 14 | ! 15 | INTEGER, DIMENSION(0:MAXLEV) :: nloop = 0 ! (0:MAXLEV) 16 | INTEGER, DIMENSION(0:MAXLEV) :: iloop = 0 ! (0:MAXLEV) 17 | INTEGER, DIMENSION(1:1 ) :: do_kpara = 0 ! (1) 18 | ! 19 | LOGICAL, DIMENSION(0:MAXLEV) :: ldostart = .false. ! (0:MAXLEV) 20 | ! 21 | REAL(KIND=PREC_DP), DIMENSION(0:MAXLEV) :: ghigh = 0.0 ! (0:MAXLEV) 22 | REAL(KIND=PREC_DP), DIMENSION(0:MAXLEV) :: glow = 0.0 ! (0:MAXLEV) 23 | REAL(KIND=PREC_DP), DIMENSION(0:MAXLEV) :: ginc = 1.0 ! (0:MAXLEV) 24 | ! 25 | END MODULE doloop_mod 26 | -------------------------------------------------------------------------------- /lib_f90/dummy_loop_mpi.f90: -------------------------------------------------------------------------------- 1 | MODULE dummy_loop_mpi_mod 2 | ! 3 | private 4 | ! 5 | public dummy_loop_mpi 6 | ! 7 | CONTAINS 8 | ! 9 | SUBROUTINE dummy_loop_mpi(prog_n, prog_l, mac_n, mac_l, out_n, out_l, repeat, nindiv) 10 | ! 11 | ! Dummy function for formal reasons shall never be called 12 | ! 13 | CHARACTER (LEN=*), INTENT(IN) :: prog_n 14 | CHARACTER (LEN=*), INTENT(IN) :: mac_n 15 | CHARACTER (LEN=*), INTENT(IN) :: out_n 16 | INTEGER , INTENT(IN) :: prog_l 17 | INTEGER , INTENT(IN) :: mac_l 18 | INTEGER , INTENT(IN) :: out_l 19 | LOGICAL , INTENT(IN) :: repeat 20 | INTEGER , INTENT(IN) :: nindiv 21 | ! 22 | END SUBROUTINE dummy_loop_mpi 23 | END MODULE dummy_loop_mpi_mod 24 | -------------------------------------------------------------------------------- /lib_f90/edit.c: -------------------------------------------------------------------------------- 1 | /******************************************************/ 2 | /* New version linking to readline library */ 3 | /******************************************************/ 4 | 5 | #ifdef VMS 6 | #define cread_ CREAD 7 | #define cinit_ CINIT 8 | #endif 9 | 10 | #ifdef hpux 11 | #define cread_ cread 12 | #define cinit_ cinit 13 | #endif 14 | 15 | #ifdef __linux__ 16 | #define _XOPEN_SOURCE 17 | #include /* for kill(2) */ 18 | #endif 19 | 20 | #include 21 | #include 22 | #include 23 | 24 | /*----------------------------------------------------*/ 25 | void cinit_() 26 | 27 | { 28 | #ifdef READLINE 29 | printf (" Command line editing enabled ..\n\n"); 30 | #else 31 | printf (" Command line editing disabled ..\n\n"); 32 | #endif 33 | } 34 | 35 | /*----------------------------------------------------*/ 36 | void cread_( char *prom, int *lp, 37 | char *inp, int *li ) 38 | { 39 | char *cprom; 40 | char *cinp; 41 | size_t len; 42 | 43 | 44 | #ifdef READLINE 45 | if( *lp <= 0 || *li <= 0 ) { /* sanity check */ 46 | *li = -1; 47 | return; 48 | } 49 | cprom = malloc( (size_t)*lp+1 ); 50 | if( !cprom ) { 51 | *li = -1; 52 | return; 53 | } 54 | strncpy( cprom, (char *)prom, (size_t)*lp ); 55 | cprom[*lp] = '\0'; 56 | cinp = readline(cprom); 57 | 58 | if(cinp && *cinp) { 59 | len = strlen(cinp); 60 | *li = len < *li ? len : *li; 61 | memcpy( inp, cinp, (size_t)*li ); 62 | add_history(cinp); 63 | free (cinp); 64 | } 65 | 66 | free (cprom); 67 | #else 68 | *li = -1; 69 | #endif 70 | return; 71 | } 72 | 73 | -------------------------------------------------------------------------------- /lib_f90/ersetzl_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE ersetzl_mod 2 | ! 3 | private 4 | ! 5 | public ersetzl 6 | ! 7 | CONTAINS 8 | ! 9 | !*****7**************************************************************** 10 | ! 11 | SUBROUTINE ersetzl (string, ikl, iklz, ww, lfunk, lll) 12 | ! 13 | ! Replaces the intrinsic logical function and its argument by the 14 | ! corresponding value ww 15 | ! 16 | USE blanks_mod 17 | IMPLICIT none 18 | ! 19 | CHARACTER (LEN= * ) , INTENT(INOUT) ::string 20 | INTEGER , INTENT(IN) :: ikl 21 | INTEGER , INTENT(IN) :: iklz 22 | LOGICAL , INTENT(IN) :: ww 23 | INTEGER , INTENT(IN) :: lfunk 24 | INTEGER , INTENT(INOUT) :: lll 25 | ! 26 | CHARACTER(LEN(STRING)):: zeile 27 | INTEGER ltot , laenge 28 | ! 29 | laenge = lll 30 | zeile = ' ' 31 | IF (ikl.gt.1) zeile (1:ikl - 1 - lfunk) = string (1:ikl - 1 - lfunk) 32 | WRITE (zeile (ikl - lfunk:ikl - lfunk ) , '(L1 )') ww 33 | lll = ikl - lfunk 34 | IF (iklz + 1.le.laenge) then 35 | ltot = (ikl - lfunk + 1 ) + (laenge-iklz - 1 + 1) - 1 36 | IF (ltot.le.len (zeile) ) then 37 | zeile (ikl - lfunk + 1 :ltot) = string (iklz + 1:laenge) 38 | lll = lll + laenge- (iklz + 1) + 1 39 | ENDIF 40 | ENDIF 41 | string = zeile 42 | CALL rem_bl (string, lll) 43 | END SUBROUTINE ersetzl 44 | ! 45 | !*****7**************************************************************** 46 | ! 47 | END MODULE ersetzl_mod 48 | -------------------------------------------------------------------------------- /lib_f90/exit_para.f90: -------------------------------------------------------------------------------- 1 | MODULE exit_para_mod 2 | ! 3 | logical :: ex_do_exit = .false. 4 | ! 5 | private 6 | public ex_do_exit 7 | ! 8 | end MODULE exit_para_mod 9 | -------------------------------------------------------------------------------- /lib_f90/gen_mpi_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE gen_mpi_mod 2 | ! 3 | ! Generic MPI related variables 4 | ! 5 | USE precision_mod 6 | ! 7 | IMPLICIT NONE 8 | ! 9 | public 10 | ! 11 | INTEGER :: gen_mpi_myid ! Id of master or slave 12 | INTEGER :: gen_mpi_numprocs ! Number of available processors 13 | ! 14 | LOGICAL :: gen_mpi_active = .false. ! With/without MPI? 15 | ! 16 | CHARACTER(LEN=PREC_STRING), DIMENSION(:) , ALLOCATABLE :: node_names ! Identifiers for each node 17 | INTEGER , DIMENSION(:) , ALLOCATABLE :: slave_is_node ! Slave is on this node number 18 | INTEGER , DIMENSION(:) , ALLOCATABLE :: kid_at_indiv ! Kid is currently at this child 19 | INTEGER , DIMENSION(:) , ALLOCATABLE :: kid_at_node ! Kid is placed onto this node 20 | INTEGER , DIMENSION(:,:), ALLOCATABLE :: node_has_kids ! Which kids are at this node 21 | INTEGER , DIMENSION(:) , ALLOCATABLE :: node_max_kids ! Maximum kids to be placed onto this node 22 | LOGICAL , DIMENSION(:) , ALLOCATABLE :: node_finished ! This node has done all its jobs 23 | ! 24 | END MODULE gen_mpi_mod 25 | -------------------------------------------------------------------------------- /lib_f90/hdf5_def.f90: -------------------------------------------------------------------------------- 1 | module hdf5_def_mod 2 | !- 3 | ! Basic definitions for HDF5 file format YELL, DISCUS 4 | !+ 5 | ! 6 | implicit none 7 | ! 8 | integer, parameter :: YD_ND =10 ! Number of data sets 9 | integer, parameter :: YD_PROGRAM = 1 10 | integer, parameter :: YD_data = 2 11 | integer, parameter :: YD_format = 3 12 | integer, parameter :: YD_is_direct = 4 13 | integer, parameter :: YD_lower_limits = 5 14 | integer, parameter :: YD_step_sizes = 6 15 | integer, parameter :: YD_unit_cell = 7 16 | integer, parameter :: YD_step_sizes_abs = 8 17 | integer, parameter :: YD_step_sizes_ord = 9 18 | integer, parameter :: YD_step_sizes_top = 10 19 | ! ! Data set names 20 | character(len=128), dimension(YD_ND), parameter :: yd_datasets = & 21 | (/ 'PROGRAM ', 'data ', 'format ', 'is_direct ', & 22 | 'lower_limits ', 'step_sizes ', 'unit_cell ', 'step_sizes_abs', & 23 | 'step_sizes_ord', 'step_sizes_top' & 24 | /) 25 | ! ! Used in YELL / DISCUS 26 | integer , dimension(YD_ND,2), parameter :: yd_req = & 27 | reshape( (/ 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, & 28 | 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 /), (/YD_ND, 2/)) 29 | ! ! Data set was read 30 | logical , dimension(YD_ND) :: yd_present = .false. 31 | ! 32 | end module hdf5_def_mod 33 | -------------------------------------------------------------------------------- /lib_f90/hdf5_params.f90: -------------------------------------------------------------------------------- 1 | module lib_hdf5_params_mod 2 | ! 3 | ! copy hdf5 parameters into DISCUS parameters 4 | ! needed just in case a user does not have HDF5 5 | ! 6 | use hdf5 7 | ! 8 | integer, parameter :: LIB_HSIZE_T = HSIZE_T 9 | integer, parameter :: LIB_HID_T = HID_T 10 | ! 11 | end module lib_hdf5_params_mod 12 | -------------------------------------------------------------------------------- /lib_f90/hdf5_params_no.f90: -------------------------------------------------------------------------------- 1 | module lib_hdf5_params_mod 2 | ! 3 | ! copy hdf5 parameters into DISCUS parameters 4 | ! needed just in case a user does not have HDF5 5 | ! Version without HDF5 6 | ! 7 | ! 8 | integer, parameter :: LIB_HSIZE_T = 8 ! == HSIZE_T 9 | integer, parameter :: LIB_HID_T = 8 ! == HID_T 10 | ! 11 | end module lib_hdf5_params_mod 12 | -------------------------------------------------------------------------------- /lib_f90/hdf_write_no.f90: -------------------------------------------------------------------------------- 1 | MODULE gen_hdf_write_mod 2 | ! 3 | contains 4 | ! 5 | !*****7***************************************************************** 6 | ! 7 | SUBROUTINE gen_hdf5_write (value, laver, outfile, out_inc, out_eck, out_vi, & 8 | extr_abs, extr_ord, extr_top, & 9 | cr_a0, cr_win, qvalues, VAL_PDF, VAL_3DPDF, valmax, & 10 | ier_num, ier_typ, ER_IO, ER_APPL) 11 | 12 | !USE hdf5 13 | !use diffuse_mod 14 | !use fourier_sup 15 | use precision_mod 16 | ! 17 | IMPLICIT NONE 18 | ! 19 | !INTEGER, PARAMETER:: PREC_DP=SELECTED_REAL_KIND(p=15,r=307) ! double precision 20 | ! 21 | INTEGER, INTENT(IN) :: value 22 | LOGICAL, INTENT(IN) :: laver 23 | CHARACTER(LEN=200), INTENT(IN) :: outfile 24 | INTEGER, DIMENSION(3) , INTENT(IN) :: out_inc 25 | REAL(kind=PREC_DP) , DIMENSION(3,4), INTENT(IN) :: out_eck ! (3,4) 26 | REAL(kind=PREC_DP) , DIMENSION(3,3), INTENT(IN) :: out_vi 27 | integer , intent(in) :: extr_abs 28 | integer , intent(in) :: extr_ord 29 | integer , intent(in) :: extr_top 30 | REAL(kind=PREC_DP) , DIMENSION(3) , INTENT(IN) :: cr_a0 31 | REAL(kind=PREC_DP) , DIMENSION(3) , INTENT(IN) :: cr_win 32 | REAL(kind=PREC_DP) , DIMENSION(out_inc(1), out_inc(2), out_inc(3)), INTENT(IN) :: qvalues 33 | INTEGER , INTENT(IN) :: VAL_PDF 34 | INTEGER , INTENT(IN) :: VAL_3DPDF 35 | REAL(KIND=PREC_DP) , INTENT(IN) :: valmax 36 | INTEGER , INTENT(OUT) :: ier_num 37 | INTEGER , INTENT(OUT) :: ier_typ 38 | INTEGER , INTENT(IN) :: ER_IO 39 | INTEGER , INTENT(IN) :: ER_APPL 40 | ! 41 | ier_num = -172 ! HDF5 not supported 42 | ier_typ = ER_APPL 43 | ! 44 | END SUBROUTINE gen_hdf5_write 45 | ! 46 | !*****7***************************************************************** 47 | ! 48 | end MODULE gen_hdf_write_mod 49 | -------------------------------------------------------------------------------- /lib_f90/learn_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE learn_mod 2 | !+ 3 | ! Learning mode flag 4 | !- 5 | USE precision_mod 6 | ! 7 | IMPLICIT NONE 8 | PUBLIC 9 | SAVE 10 | ! 11 | CHARACTER(LEN=PREC_STRING) :: fname 12 | LOGICAL :: llearn = .false. 13 | ! 14 | END MODULE learn_mod 15 | -------------------------------------------------------------------------------- /lib_f90/lib_element_status.f90: -------------------------------------------------------------------------------- 1 | module lib_element_status_mod 2 | !- 3 | ! Status for the guess work on element nacmes 4 | !+ 5 | ! 6 | integer, parameter :: IS_FAIL = -1 7 | integer, parameter :: IS_NEUTRAL = 1 8 | integer, parameter :: IS_ION = 2 9 | integer, parameter :: IS_EQUIVALENT = 3 10 | integer, parameter :: IS_GUESS = 4 11 | integer, parameter :: IS_GUESS_2 = 5 12 | integer, parameter :: IS_GUESS_1 = 6 13 | ! 14 | end module lib_element_status_mod 15 | -------------------------------------------------------------------------------- /lib_f90/lib_f90_alloc.f90: -------------------------------------------------------------------------------- 1 | module lib_f90_allocate_mod 2 | ! 3 | use allocate_generic 4 | use errlist_mod 5 | ! 6 | contains 7 | ! 8 | subroutine alloc_param(n_res) 9 | ! 10 | use param_mod 11 | ! 12 | implicit none 13 | ! 14 | integer, intent(in) :: n_res 15 | integer :: all_status 16 | ! 17 | call alloc_arr(res_para, 0, n_res, all_status, 0.0D0 ) 18 | ! 19 | end subroutine alloc_param 20 | ! 21 | !******************************************************************************* 22 | ! 23 | subroutine alloc_ref_para(n_para) 24 | ! 25 | use param_mod 26 | ! 27 | implicit none 28 | ! 29 | integer, intent(in) :: n_para 30 | integer :: all_status 31 | ! 32 | call alloc_arr(ref_para, 0, n_para, all_status, 0.0D0 ) 33 | MAXPAR_REF = n_para 34 | ! 35 | end subroutine alloc_ref_para 36 | ! 37 | !******************************************************************************* 38 | ! 39 | subroutine alloc_expr(n_expr) 40 | !- 41 | ! Allocate the array for expressions 42 | !+ 43 | ! 44 | use variable_mod 45 | ! 46 | implicit none 47 | ! 48 | integer, intent(in) :: n_expr 49 | integer :: all_status 50 | ! 51 | call alloc_arr(var_expr, 1, n_expr, all_status, ' ') 52 | call alloc_arr(var_expr_val, 1, n_expr, all_status, 0.0D0) 53 | var_entry(VAR_EXPRESSION) = n_expr ! Store dimension 54 | ! 55 | end subroutine alloc_expr 56 | ! 57 | !******************************************************************************* 58 | ! 59 | end module lib_f90_allocate_mod 60 | -------------------------------------------------------------------------------- /lib_f90/lib_f90_default.f90: -------------------------------------------------------------------------------- 1 | module lib_f90_default_mod 2 | ! 3 | use lib_f90_allocate_mod 4 | use param_mod 5 | ! 6 | implicit none 7 | ! 8 | contains 9 | ! 10 | !******************************************************************************* 11 | ! 12 | subroutine lib_alloc_default 13 | ! 14 | integer :: n_res 15 | integer :: n_para 16 | integer :: n_expr 17 | ! 18 | n_res = MAX(MAXPAR_RES, 6000) 19 | call alloc_param(n_res) 20 | MAXPAR_RES = n_res 21 | n_para = 1 22 | call alloc_ref_para(n_para) 23 | n_expr = 1 24 | call alloc_expr(n_expr) 25 | ! 26 | end subroutine lib_alloc_default 27 | ! 28 | !******************************************************************************* 29 | ! 30 | end module lib_f90_default_mod 31 | -------------------------------------------------------------------------------- /lib_f90/lib_f90_fftw3.f90: -------------------------------------------------------------------------------- 1 | module lib_f90_fftw3 2 | ! 3 | use iso_c_binding 4 | ! 5 | include 'fftw3.f03' 6 | ! 7 | end module lib_f90_fftw3 8 | -------------------------------------------------------------------------------- /lib_f90/lib_functions.f90: -------------------------------------------------------------------------------- 1 | module lib_functions_mod 2 | ! 3 | ! Low level function of generic use 4 | !+ 5 | ! 6 | contains 7 | ! 8 | !############################################################################### 9 | ! 10 | function sinc(x) result(val) 11 | !- 12 | ! sinc function: sin(x)/x 13 | !+ 14 | use precision_mod 15 | ! 16 | implicit none 17 | ! 18 | real(kind=PREC_DP) :: val 19 | ! 20 | real(kind=PREC_DP), intent(in) :: x 21 | ! 22 | real(kind=PREC_DP), parameter :: TOL=1.0D-7 23 | ! 24 | if(abs(x) at exit: writes last data set into DISCUS_SUITE_DERIVATIVES/data.iiii.jjjj (REF_KID, REF_INDIV) 12 | ! (2) : unused 13 | ! (3) : unused 14 | ! (4) : unused 15 | ! (5) : unused 16 | ! (6) : unused 17 | ! (7) : unused 18 | ! (8) : unused 19 | ! 20 | contains 21 | ! 22 | !******************************************************************************+ 23 | ! 24 | subroutine lib_global_flags_reset 25 | !- 26 | ! Everything back to zero 27 | !+ 28 | implicit none 29 | lib_global_flags = 0 30 | ! 31 | end subroutine lib_global_flags_reset 32 | ! 33 | !******************************************************************************+ 34 | ! 35 | end module lib_global_flags_mod 36 | -------------------------------------------------------------------------------- /lib_f90/macro_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE macro_mod 2 | !+ 3 | ! include file for file related variables, all macro stuff is "macro_internal.f90" 4 | !- 5 | USE precision_mod 6 | IMPLICIT NONE 7 | PUBLIC 8 | SAVE 9 | ! 10 | INTEGER, PARAMETER :: MAC_MAX_LEVEL = 10 11 | INTEGER, PARAMETER :: MAC_MAX_PARA = 20 12 | INTEGER, PARAMETER :: MAC_MAX_IO = 20 13 | INTEGER, PARAMETER :: MAC_MAX_FORM = 50 14 | ! 15 | logical :: lmakro_dbg = .FALSE. 16 | ! 17 | CHARACTER(LEN=PREC_STRING), DIMENSION(1:MAC_MAX_IO ) :: io_file ! (MAC_MAX_IO) 18 | CHARACTER(LEN=20 ), DIMENSION(1:MAC_MAX_FORM ) :: io_out_format ! (MAC_MAX_FORM) 19 | LOGICAL , DIMENSION(1:MAC_MAX_IO ) :: io_open ! (MAC_MAX_IO) 20 | INTEGER , DIMENSION(1:MAC_MAX_IO ) :: io_unit ! (MAC_MAX_IO) 21 | LOGICAL , DIMENSION(1:MAC_MAX_IO ) :: io_eof ! (MAC_MAX_IO) 22 | INTEGER , DIMENSION(1:MAC_MAX_IO, 2) :: io_get_sub ! (MAC_MAX_IO,2) 23 | ! 24 | END MODULE macro_mod 25 | -------------------------------------------------------------------------------- /lib_f90/memory.f90: -------------------------------------------------------------------------------- 1 | MODULE lib_memory_func 2 | ! 3 | CONTAINS 4 | ! 5 | subroutine memory_message(cpara) 6 | ! 7 | ! debug routine to find memory leak, currently offline 8 | ! 9 | USE precision_mod 10 | use mpi_slave_mod 11 | IMPLICIT NONE 12 | character(Len=*), intent(IN) :: cpara 13 | character(len=PREC_STRING) :: zei 14 | !DBG_MEM 15 | !DBG_MEM 16 | character(len=PREC_STRING):: pid_status 17 | character(len=8 ):: pid_char 18 | integer::my_pid 19 | integer::ios 20 | integer::vmpeak = 0 21 | integer::vmsize = 0 22 | integer::vmlck = 0 23 | integer::vmpin = 0 24 | integer::vmhwm = 0 25 | integer::vmrss = 0 26 | integer::vmdata = 0 27 | integer::vmstk = 0 28 | integer::vmexe = 0 29 | integer::vmlib = 0 30 | integer::vmpte = 0 31 | integer::vmswap = 0 32 | my_pid=12345678 33 | !my_pid=getpid() Works for gfortran only 34 | write(pid_char,'(I8)') my_pid 35 | pid_status = '/proc/'//TRIM(ADJUSTL(pid_char))//'/status' 36 | open(unit=100,file=pid_status,action='read') 37 | memory: do 38 | read(100,'(a)',IOSTAT=ios) zei 39 | if(ios/=0) exit memory 40 | if(zei(1:7)=='VmPeak:') read(zei(8:),*) vmpeak 41 | if(zei(1:7)=='VmSize:') read(zei(8:),*) vmsize 42 | if(zei(1:6)=='VmLck:' ) read(zei(7:),*) vmlck 43 | if(zei(1:6)=='VmPin:' ) read(zei(7:),*) vmpin 44 | if(zei(1:6)=='VmHWM:' ) read(zei(7:),*) vmhwm 45 | if(zei(1:6)=='VmRSS:' ) read(zei(7:),*) vmrss 46 | if(zei(1:7)=='VmDATA:') read(zei(8:),*) vmdata 47 | if(zei(1:6)=='VmStk:' ) read(zei(7:),*) vmstk 48 | if(zei(1:6)=='VmExe:' ) read(zei(7:),*) vmexe 49 | if(zei(1:6)=='VmLib:' ) read(zei(7:),*) vmlib 50 | if(zei(1:6)=='VmPTE:' ) read(zei(7:),*) vmpte 51 | if(zei(1:7)=='VmSwap:') read(zei(8:),*) vmswap 52 | enddo memory 53 | close(100) 54 | !write(101,'(a20,12(1x,I10))') cpara(1:20),vmpeak,vmsize,vmlck, vmpin,vmhwm,vmrss,& 55 | ! vmdata,vmstk,vmexe,vmlib,vmpte,vmswap 56 | write(101,'(a20, 5(1x,I10))') cpara(1:20),vmpeak,vmsize, vmhwm,vmrss, vmpte 57 | end subroutine memory_message 58 | END MODULE lib_memory_func 59 | -------------------------------------------------------------------------------- /lib_f90/mpi_slave_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE mpi_slave_mod 2 | ! 3 | LOGICAL :: mpi_active = .false. 4 | LOGICAL :: mpi_is_slave = .false. 5 | INTEGER :: mpi_slave_error = 0 6 | INTEGER :: mpi_slave_err_typ = 0 7 | character(len=80), dimension(7) :: mpi_slave_msg = ' ' 8 | ! 9 | END MODULE mpi_slave_mod 10 | -------------------------------------------------------------------------------- /lib_f90/op_linux.f90: -------------------------------------------------------------------------------- 1 | MODULE operating_mod 2 | ! 3 | ! Operating system dependent code 4 | ! LINUX Version 5 | ! 6 | INTEGER, PARAMETER :: OP_LINUX = 1 7 | INTEGER, PARAMETER :: OP_MAC = 2 8 | INTEGER, PARAMETER :: OP_WINDOWS = 3 9 | ! 10 | INTEGER, PARAMETER :: OP_SYSTEM = OP_LINUX 11 | ! 12 | CONTAINS 13 | ! 14 | SUBROUTINE get_mpi_path(mpi_path) 15 | ! 16 | ! Find path to 'mpiexec' command 17 | ! For Windows version this is fixed 18 | ! 19 | USE precision_mod 20 | USE envir_mod 21 | ! 22 | IMPLICIT NONE 23 | ! 24 | CHARACTER(LEN=PREC_STRING), INTENT(OUT) :: mpi_path 25 | ! 26 | CHARACTER(LEN=PREC_STRING) :: mpi_file 27 | LOGICAL :: lda 28 | ! 29 | IF(start_line(1:start_line_l) == 'discus_suite_noparallel') THEN 30 | mpi_file = '/bin/mpiexec' 31 | INQUIRE(FILE=mpi_file, EXIST=lda) 32 | IF(lda) THEN 33 | mpi_path = '/bin' 34 | ELSE 35 | mpi_file = '/usr/bin/mpiexec' 36 | INQUIRE(FILE=mpi_file, EXIST=lda) 37 | IF(lda) THEN 38 | mpi_path = '/usr/bin' 39 | ELSE 40 | mpi_path = ' ' 41 | ENDIF 42 | ENDIF 43 | ELSE 44 | mpi_path = ' ' ! Turn MPI path empty 45 | ENDIF 46 | ! 47 | END SUBROUTINE get_mpi_path 48 | ! 49 | SUBROUTINE get_discus_path(discus_path, discus_name) 50 | ! 51 | ! Find path to 'discus_suite' command 52 | ! For Windows version this is fixed 53 | ! 54 | IMPLICIT NONE 55 | ! 56 | CHARACTER(LEN=*), INTENT(OUT) :: discus_path 57 | CHARACTER(LEN=*), INTENT(OUT) :: discus_name 58 | ! 59 | discus_path = '/usr/local/bin/' 60 | discus_name = 'discus_suite' 61 | ! 62 | END SUBROUTINE get_discus_path 63 | ! 64 | SUBROUTINE operating_exit 65 | ! 66 | USE envir_mod 67 | USE prompt_mod 68 | ! 69 | IMPLICIT NONE 70 | ! 71 | ! Currently no need for specifics 72 | ! 73 | ! 74 | END SUBROUTINE operating_exit 75 | ! 76 | !******************************************************************************* 77 | ! 78 | END MODULE operating_mod 79 | -------------------------------------------------------------------------------- /lib_f90/op_macos.f90: -------------------------------------------------------------------------------- 1 | MODULE operating_mod 2 | ! 3 | ! Operating system dependent code 4 | ! MACOS Version 5 | ! 6 | INTEGER, PARAMETER :: OP_LINUX = 1 7 | INTEGER, PARAMETER :: OP_MAC = 2 8 | INTEGER, PARAMETER :: OP_WINDOWS = 3 9 | ! 10 | INTEGER, PARAMETER :: OP_SYSTEM = OP_MAC 11 | ! 12 | CONTAINS 13 | ! 14 | SUBROUTINE get_mpi_path(mpi_path) 15 | ! 16 | ! Find path to 'mpiexec' command 17 | ! For Windows version this is fixed 18 | ! 19 | USE precision_mod 20 | ! 21 | IMPLICIT NONE 22 | ! 23 | CHARACTER(LEN=PREC_STRING), INTENT(OUT) :: mpi_path 24 | ! 25 | mpi_path = ' ' ! Turn mpi_path empty 26 | ! 27 | END SUBROUTINE get_mpi_path 28 | ! 29 | SUBROUTINE get_discus_path(discus_path, discus_name) 30 | ! 31 | ! Find path to 'discus_suite' command 32 | ! For Windows version this is fixed 33 | ! 34 | IMPLICIT NONE 35 | ! 36 | CHARACTER(LEN=*), INTENT(OUT) :: discus_path 37 | CHARACTER(LEN=*), INTENT(OUT) :: discus_name 38 | ! 39 | discus_path = '/bin/' 40 | discus_name = 'discus_suite' 41 | ! 42 | END SUBROUTINE get_discus_path 43 | ! 44 | SUBROUTINE operating_exit 45 | ! 46 | USE prompt_mod 47 | IMPLICIT NONE 48 | ! 49 | ! Currently no need for specifics 50 | ! 51 | END SUBROUTINE operating_exit 52 | END MODULE operating_mod 53 | -------------------------------------------------------------------------------- /lib_f90/op_windows.f90: -------------------------------------------------------------------------------- 1 | MODULE operating_mod 2 | ! 3 | INTEGER, PARAMETER :: OP_LINUX = 1 4 | INTEGER, PARAMETER :: OP_MAC = 2 5 | INTEGER, PARAMETER :: OP_WINDOWS = 3 6 | ! 7 | INTEGER, PARAMETER :: OP_SYSTEM = OP_WINDOWS 8 | ! 9 | CONTAINS 10 | ! 11 | SUBROUTINE get_mpi_path(mpi_path) 12 | ! 13 | ! Find path to 'mpiexec' command 14 | ! For Windows version this is fixed 15 | ! 16 | USE precision_mod 17 | IMPLICIT NONE 18 | ! 19 | CHARACTER(LEN=PREC_STRING), INTENT(OUT) :: mpi_path 20 | ! 21 | mpi_path = '/bin' 22 | ! 23 | END SUBROUTINE get_mpi_path 24 | ! 25 | SUBROUTINE get_discus_path(discus_path, discus_name) 26 | ! 27 | ! Find path to 'discus_suite' command 28 | ! For Windows version this is fixed 29 | ! 30 | IMPLICIT NONE 31 | ! 32 | CHARACTER(LEN=*), INTENT(OUT) :: discus_path 33 | CHARACTER(LEN=*), INTENT(OUT) :: discus_name 34 | ! 35 | discus_path = '/bin/' 36 | discus_name = 'discus_suite_parallel.exe' 37 | ! 38 | END SUBROUTINE get_discus_path 39 | ! 40 | SUBROUTINE operating_exit 41 | ! 42 | USE prompt_mod 43 | IMPLICIT NONE 44 | ! 45 | ! Currently no need for specific exit 46 | !IF(.NOT. lstandalone .OR. pname_CAP == 'KUPLOT') THEN 47 | ! WRITE(*,*) ' ' 48 | ! WRITE(*,*) pname_cap,' is finished' 49 | ! WRITE(*,*) 'Close PGPLOT window ' 50 | ! WRITE(*,*) 'If this is the primary window close pgplot_server as well' 51 | ! WRITE(*,*) 'Finally close this window as well' 52 | ! WRITE(*,*) ' ' 53 | !ENDIF 54 | ! 55 | END SUBROUTINE operating_exit 56 | END MODULE operating_mod 57 | -------------------------------------------------------------------------------- /lib_f90/parallel_CUDA.f90: -------------------------------------------------------------------------------- 1 | MODULE parallel_mod 2 | !- 3 | ! Variables related to parallel processing using OMP 4 | !+ 5 | LOGICAL :: par_omp_use = .FALSE. ! User does not want to use OMP 6 | INTEGER :: par_omp_maxthreads = 1 ! Maximum number of threads to use, 1 7 | ! 8 | !******************************************************************************* 9 | ! 10 | SUBROUTINE get_cores() 11 | ! 12 | END SUBROUTINE get_cores() 13 | ! 14 | !******************************************************************************* 15 | ! 16 | END MODULE parallel_mod 17 | -------------------------------------------------------------------------------- /lib_f90/parallel_none.f90: -------------------------------------------------------------------------------- 1 | MODULE parallel_mod 2 | !- 3 | ! Variables related to parallel processing using CUDA 4 | !+ 5 | LOGICAL :: par_omp_use = .FALSE. ! User does not want to use OMP 6 | INTEGER :: par_omp_maxthreads = 1 ! Maximum number of threads to use, 1 7 | INTEGER :: par_omp_phys = 1 ! Maximum number of threads to use, 1 8 | INTEGER :: par_omp_logi = 1 ! Maximum number of threads to use, 1 9 | ! 10 | CONTAINS 11 | ! 12 | !******************************************************************************* 13 | ! 14 | SUBROUTINE get_cores() 15 | ! 16 | END SUBROUTINE get_cores 17 | ! 18 | !******************************************************************************* 19 | ! 20 | END MODULE parallel_mod 21 | -------------------------------------------------------------------------------- /lib_f90/param_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE param_mod 2 | !+ 3 | ! Include file for free variables 4 | ! 5 | ! Warning! MAXPAR_RES in "param.inc" must always be of 6 | ! identical size to 7 | ! CHEM_MAX_NEIG in DISCUS/"config.inc" 8 | ! This warning is obsolete. 9 | !- 10 | USE precision_mod 11 | ! 12 | IMPLICIT NONE 13 | PUBLIC 14 | SAVE 15 | ! 16 | INTEGER, PARAMETER :: MAXPAR = 500 17 | INTEGER :: MAXPAR_RES = 6000 18 | INTEGER :: MAXPAR_REF = 1 19 | ! 20 | INTEGER , DIMENSION(0:MAXPAR) :: inpara = 0 ! (0:MAXPAR) 21 | REAL(kind=PREC_DP), DIMENSION(0:MAXPAR) :: rpara = 0.0 ! (0:MAXPAR) 22 | REAL(KIND=PREC_DP), DIMENSION(:),ALLOCATABLE:: res_para ! (0:MAXPAR_RES) 23 | REAL(kind=PREC_DP), DIMENSION(:),ALLOCATABLE:: ref_para ! Defined by DIFFEV 24 | REAL(kind=PREC_DP), DIMENSION(0:MAXPAR) :: kupl_para = 0.0 ! (0:MAXPAR) 25 | REAL(kind=PREC_DP), DIMENSION(0:MAXPAR) :: kupl_deriv= 0.0 ! (0:MAXPAR) 26 | INTEGER :: nrvalues = 0 27 | REAL(kind=PREC_DP), DIMENSION(1:2, 0:15) :: rvalues = 0.0 ! (1:2) 28 | LOGICAL :: rvalue_yes = .false. 29 | ! 30 | END MODULE param_mod 31 | -------------------------------------------------------------------------------- /lib_f90/precision_command_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE precision_command_mod 2 | ! 3 | CHARACTER(LEN=2), PARAMETER :: C_WIDTH = '20' ! '15' 4 | CHARACTER(LEN=2), PARAMETER :: C_EXPO = '03' ! '02' 5 | ! Overall width WW 20 15 6 | INTEGER, PARAMETER :: PREC_WIDTH = 10*(IACHAR(C_WIDTH(1:1))-IACHAR('0')) & 7 | + (IACHAR(C_WIDTH(2:2))-IACHAR('0')) 8 | INTEGER, PARAMETER :: PREC_EXPO = 10*(IACHAR(C_EXPO (1:1))-IACHAR('0')) & 9 | + (IACHAR(C_EXPO (2:2))-IACHAR('0')) 10 | ! Digits in exponent xx 3 2 11 | INTEGER, PARAMETER :: PREC_MANTIS = PREC_WIDTH - PREC_EXPO - 2 ! width left of E+xx 15 11 12 | INTEGER, PARAMETER :: PREC_DIGIT = PREC_MANTIS - 3 ! Significant digits DD 12 8 13 | ! 14 | ! Automatically build format string '(E15.08E02)' ! Format string EWW.DDExx 15 | CHARACTER(LEN=24), PARAMETER :: PREC_F_REAL = & 16 | '(E' // C_WIDTH // '.' // & 17 | ACHAR(PREC_DIGIT/10+IACHAR('0')) // & 18 | ACHAR(MOD(PREC_DIGIT,10)+IACHAR('0')) // 'E' // C_EXPO // ')' 19 | ! 20 | ! Automatically build format string '(I15)' ! Format string IWW 21 | CHARACTER(LEN=24), PARAMETER :: PREC_F_INTE = '(I' // C_WIDTH // ')' 22 | ! 23 | END MODULE precision_command_mod 24 | -------------------------------------------------------------------------------- /lib_f90/precision_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE precision_mod 2 | ! 3 | use iso_fortran_env 4 | ! 5 | INTEGER, PARAMETER:: PREC_INT_BYTE = 1 6 | INTEGER, PARAMETER:: PREC_INT_SHORT = 2 7 | INTEGER, PARAMETER:: PREC_INT_WORD = 4 8 | INTEGER, PARAMETER:: PREC_INT_LONG = 8 9 | INTEGER, PARAMETER:: PREC_INT_LARGE=MAX(SELECTED_INT_KIND(8) , & 10 | SELECTED_INT_KIND(16) ) 11 | INTEGER, PARAMETER:: PREC_SP=SELECTED_REAL_KIND(p= 6 ) ! single precision 12 | INTEGER, PARAMETER:: PREC_DP=SELECTED_REAL_KIND(p=15,r=307) ! double precision 13 | INTEGER, PARAMETER:: PREC_QP=SELECTED_REAL_KIND(p=30,r=307) ! quad precision 14 | INTEGER, PARAMETER:: PREC_HP=SELECTED_REAL_KIND(p=30,r=607) ! quad precision 15 | ! 16 | INTEGER, PARAMETER:: PREC_STRING = 1024 17 | INTEGER, PARAMETER:: PREC_LSTRING = 2048 18 | ! 19 | ! 20 | END MODULE precision_mod 21 | -------------------------------------------------------------------------------- /lib_f90/prompt_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE prompt_mod 2 | !+ 3 | ! Variables for program prompt 4 | !- 5 | USE precision_mod 6 | ! 7 | IMPLICIT NONE 8 | PUBLIC 9 | SAVE 10 | ! 11 | INTEGER, PARAMETER :: PROMPT_ON = 0 12 | INTEGER, PARAMETER :: PROMPT_OFF = 1 13 | INTEGER, PARAMETER :: PROMPT_MACRO = 2 14 | INTEGER, PARAMETER :: PROMPT_REDIRECT = 3 15 | ! 16 | INTEGER, PARAMETER :: OUTPUT_SCREEN = 1 17 | INTEGER, PARAMETER :: OUTPUT_NONE = 2 18 | INTEGER, PARAMETER :: OUTPUT_FILE = 3 19 | ! 20 | CHARACTER(LEN= PREC_STRING) :: blank 21 | CHARACTER(LEN= PREC_STRING) :: input_gui 22 | CHARACTER(LEN= 80 ) :: s_ipallowed 23 | CHARACTER(LEN= 40 ) :: prompt 24 | CHARACTER(LEN= 40 ) :: prompt_stop 25 | CHARACTER(LEN= 40 ) :: oprompt 26 | CHARACTER(LEN= 10 ) :: version 27 | CHARACTER(LEN= 7 ) :: pname,pname_cap 28 | INTEGER :: s_port 29 | INTEGER :: s_sock 30 | INTEGER :: s_conid 31 | INTEGER :: s_remote 32 | INTEGER :: prompt_status = PROMPT_ON 33 | INTEGER :: prompt_status_old = PROMPT_ON 34 | INTEGER :: output_status = OUTPUT_SCREEN 35 | INTEGER :: output_status_old = OUTPUT_SCREEN 36 | INTEGER :: output_io 37 | INTEGER :: error_io 38 | ! INTEGER :: socket_status = OUTPUT_SCREEN 39 | ! INTEGER :: socket_status_old = OUTPUT_SCREEN 40 | LOGICAL :: first_input 41 | ! LOGICAL :: lsocket = .false. 42 | LOGICAL :: lconn = .false. 43 | LOGICAL :: lremote = .false. 44 | LOGICAL :: lsetup_done = .false. 45 | LOGICAL :: lstandalone = .true. 46 | LOGICAL :: linteractive = .true. 47 | LOGICAL :: lturn_off = .true. 48 | LOGICAL :: l_to_top = .FALSE. 49 | ! 50 | END MODULE prompt_mod 51 | -------------------------------------------------------------------------------- /lib_f90/random_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE random_mod 2 | !+ 3 | ! 4 | ! This file contains variables for seed for random number 5 | ! generator and the definition for the random number generator 6 | ! function. 7 | !- 8 | IMPLICIT NONE 9 | PUBLIC 10 | SAVE 11 | ! 12 | INTEGER :: idum = -182783467 13 | INTEGER :: iset = 0 14 | ! 15 | ! 16 | END MODULE random_mod 17 | -------------------------------------------------------------------------------- /lib_f90/sine_table.f90: -------------------------------------------------------------------------------- 1 | MODULE sine_table_mod 2 | ! 3 | ! Lookup tables for SINE and COSINE functions 4 | ! Needed for a (reasonabley) fast explicit FOURIER 5 | ! The argument is in radians 6 | ! 7 | USE precision_mod 8 | ! 9 | ! 10 | INTEGER(KIND=PREC_INT_LARGE) , PARAMETER :: ST_I2PI = 2**16 11 | INTEGER(KIND=PREC_INT_LARGE) , PARAMETER :: ST_MASK = ST_I2PI-1 12 | 13 | REAL(KIND=PREC_DP), DIMENSION(:), ALLOCATABLE :: sine 14 | REAL(KIND=PREC_DP), DIMENSION(:), ALLOCATABLE :: cosine 15 | ! 16 | CONTAINS 17 | ! 18 | !******************************************************************************* 19 | ! 20 | SUBROUTINE set_sine 21 | ! 22 | USE wink_mod 23 | ! 24 | IMPLICIT NONE 25 | ! 26 | INTEGER :: i 27 | ! 28 | IF(.NOT.ALLOCATED(sine)) THEN 29 | ! 30 | ALLOCATE(sine(0:ST_MASK)) 31 | ! 32 | DO i=0, ST_MASK 33 | sine(i) = SIN(REAL(i*zpi/ST_I2PI,KIND(1.0D0))) 34 | ENDDO 35 | ENDIF 36 | ! 37 | END SUBROUTINE set_sine 38 | ! 39 | !******************************************************************************* 40 | ! 41 | SUBROUTINE set_cosine 42 | ! 43 | USE wink_mod 44 | ! 45 | IMPLICIT NONE 46 | ! 47 | INTEGER :: i 48 | ! 49 | IF(.NOT.ALLOCATED(cosine)) THEN 50 | ! 51 | ALLOCATE(cosine(0:ST_MASK)) 52 | ! 53 | DO i=0, ST_MASK 54 | cosine(i) = COS(REAL(i*zpi/ST_I2PI,KIND(1.0D0))) 55 | ENDDO 56 | ENDIF 57 | ! 58 | END SUBROUTINE set_cosine 59 | ! 60 | !******************************************************************************* 61 | ! 62 | END MODULE sine_table_mod 63 | -------------------------------------------------------------------------------- /lib_f90/str_comp_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE str_comp_mod 2 | ! 3 | CONTAINS 4 | ! 5 | !*****7*********************************************************** 6 | LOGICAL FUNCTION str_comp (a, b, j, la, lb) 7 | !- 8 | ! compares the first non blank characters of the two strings 9 | ! for equality. At least j characters must be identical. 10 | !+ 11 | ! 12 | use precision_mod 13 | IMPLICIT none 14 | ! 15 | CHARACTER(LEN=*), INTENT(IN) :: a, b 16 | INTEGER , INTENT(IN) :: j, la, lb 17 | ! 18 | !character(len=PREC_STRING) :: aa 19 | !character(len=PREC_STRING) :: bb 20 | INTEGER i, ia, ib 21 | ! 22 | IF (la == 0 .OR. lb == 0) THEN 23 | str_comp = .false. 24 | ELSE 25 | ia = MIN (INDEX (a, ' ') , la) 26 | ib = MIN (INDEX (b, ' ') , lb) 27 | IF (ia == 0) THEN 28 | ia = la 29 | ENDIF 30 | IF (ib == 0) THEN 31 | ib = lb 32 | ENDIF 33 | i = MIN (ia, ib) 34 | i = max (ia, ib) 35 | i = MIN (i, la) 36 | i = MIN (i, lb) 37 | ! 38 | ! aa = ' ' 39 | ! bb = ' ' 40 | ! aa = a(1:len_trim(a)) 41 | ! bb = b(1:len_trim(b)) 42 | ! i = max(len_trim(aa), len_trim(bb)) 43 | !if(bb(1:3)=='var') then 44 | !write(*,*) ' AA >',aa(1:len_trim(aa)),'<>', i, ' >>',aa(1:i),'<<' 45 | !write(*,*) ' BB >',bb(1:len_trim(bb)),'<>', j, ' >>',bb(1:i),'<<' 46 | !write(*,*) ' == ', aa(1:i) .eq.bb(1:i) 47 | !endif 48 | IF (i < j) THEN 49 | str_comp = .false. 50 | ELSE 51 | str_comp = a (1:i) .eq.b (1:i) 52 | ! str_comp = aa(1:i) .eq.bb(1:i) 53 | ENDIF 54 | ENDIF 55 | ! 56 | END FUNCTION str_comp 57 | !*****7*********************************************************** 58 | END MODULE str_comp_mod 59 | -------------------------------------------------------------------------------- /lib_f90/times_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE times_mod 2 | !+ 3 | ! This file contains the time related variables 4 | !- 5 | IMPLICIT NONE 6 | PUBLIC 7 | SAVE 8 | ! 9 | INTEGER, DIMENSION(3) :: int_time 10 | INTEGER, DIMENSION(3) :: int_date 11 | INTEGER :: millisec 12 | INTEGER :: midnight 13 | ! 14 | CHARACTER (LEN=24) :: f_modt 15 | CHARACTER (LEN=24) :: f_date 16 | ! 17 | ! 18 | END MODULE times_mod 19 | -------------------------------------------------------------------------------- /lib_f90/variable_array_calc.f90: -------------------------------------------------------------------------------- 1 | MODULE variable_array_calc_mod 2 | ! 3 | CONTAINS 4 | ! 5 | SUBROUTINE var_arr_mul(line, length) 6 | ! 7 | USE get_params_mod 8 | USE ber_params_mod 9 | USE precision_mod 10 | USE variable_mod 11 | ! 12 | IMPLICIT NONE 13 | ! 14 | CHARACTER(LEN=*), INTENT(INOUT) :: line 15 | INTEGER , INTENT(INOUT) :: length 16 | ! 17 | INTEGER, PARAMETER :: MAXP = 3 18 | CHARACTER(LEN=MAX(PREC_STRING,LEN(line))), DIMENSION(MAXP) :: cpara 19 | INTEGER , DIMENSION(MAXP) :: lpara 20 | REAL(KIND=PREC_DP) , DIMENSION(MAXP) :: werte 21 | INTEGER :: ianz 22 | ! 23 | CALL get_params (line, ianz, cpara, lpara, MAXP, length) 24 | ! 25 | END SUBROUTINE var_arr_mul 26 | END MODULE variable_array_calc_mod 27 | -------------------------------------------------------------------------------- /lib_f90/variable_test.f90: -------------------------------------------------------------------------------- 1 | module variable_test 2 | ! 3 | use variable_mod 4 | ! 5 | implicit none 6 | ! 7 | contains 8 | ! 9 | subroutine variable_exist(c_temp,l_temp, c_type, l_exist, l_type, var_no) 10 | ! 11 | character (LEN=*), intent(in) :: c_temp ! Name to be tested 12 | integer , intent(in) :: l_temp ! length of input name 13 | integer , INTENT(in) :: c_type ! Type of input variable 14 | logical , intent(out) :: l_exist ! True if exists 15 | logical , intent(out) :: l_type ! True if correct type 16 | integer , intent(out) :: var_no ! variable number if exists 17 | ! 18 | integer :: i 19 | ! 20 | l_exist = .false. 21 | l_type = .false. 22 | var_no = 0 23 | ! 24 | search: do i=1,var_num 25 | if( c_temp(1:l_temp) == var_name(i)) then 26 | l_exist = .true. 27 | var_no = i 28 | if( c_type == var_type(i)) then 29 | l_type = .true. 30 | endif 31 | exit search 32 | endif 33 | enddo search 34 | ! 35 | end subroutine variable_exist 36 | ! 37 | end module variable_test 38 | -------------------------------------------------------------------------------- /lib_f90/version.inc.template: -------------------------------------------------------------------------------- 1 | @DIFFUSE_VERSION_MAJOR@.@DIFFUSE_VERSION_MINOR@.@DIFFUSE_VERSION_PATCH@ 2 | -------------------------------------------------------------------------------- /lib_f90/win32-glob.h: -------------------------------------------------------------------------------- 1 | /* libSoX minimal glob for MS-Windows: (c) 2009 SoX contributors 2 | * 3 | * This library is free software; you can redistribute it and/or modify it 4 | * under the terms of the GNU Lesser General Public License as published by 5 | * the Free Software Foundation; either version 2.1 of the License, or (at 6 | * your option) any later version. 7 | * 8 | * This library is distributed in the hope that it will be useful, but 9 | * WITHOUT ANY WARRANTY; without even the implied warranty of 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser 11 | * General Public License for more details. 12 | * 13 | * You should have received a copy of the GNU Lesser General Public License 14 | * along with this library; if not, write to the Free Software Foundation, 15 | * Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 16 | */ 17 | 18 | #ifndef GLOB_H 19 | #define GLOB_H 1 20 | 21 | #define GLOB_NOCHECK (16) 22 | #define GLOB_FLAGS (GLOB_NOCHECK) 23 | 24 | typedef struct glob_t 25 | { 26 | unsigned gl_pathc; 27 | char **gl_pathv; 28 | } glob_t; 29 | 30 | #ifdef __cplusplus 31 | extern "C" { 32 | #endif 33 | 34 | int 35 | glob( 36 | const char *pattern, 37 | int flags, 38 | void *unused, 39 | glob_t *pglob); 40 | 41 | void 42 | globfree( 43 | glob_t* pglob); 44 | 45 | #ifdef __cplusplus 46 | } 47 | #endif 48 | 49 | #endif /* ifndef GLOB_H */ 50 | -------------------------------------------------------------------------------- /lib_f90/wink_mod.f90: -------------------------------------------------------------------------------- 1 | module wink_mod 2 | !+ 3 | ! This file the definitions for radian, 2 pi 4 | !- 5 | use precision_mod 6 | implicit none 7 | public 8 | save 9 | ! 10 | real(PREC_DP), parameter :: pi = 3.1415926535897932384626433832795028841971693993751D0 11 | real(PREC_DP), parameter :: zpi = 2.0D0 * pi 12 | real(PREC_DP), parameter :: fpi = 4.0D0 * pi 13 | real(PREC_DP), parameter :: rad = pi/180.D0 14 | ! 15 | ! 16 | end module wink_mod 17 | -------------------------------------------------------------------------------- /mixscat/examples/cef3.cll: -------------------------------------------------------------------------------- 1 | title cef3 2 | spcgr P-3c1 3 | cell 7.131 7.131 7.286 90 90 120 4 | atoms 5 | Ce 0.66070000 0.00000000 0.2500 0.2 6 | F 0.36590000 0.05400000 0.0824 0.2 7 | F 0.33333333 0.66666667 0.1871 0.2 8 | F 0.00000000 0.00000000 0.2500 0.2 9 | 10 | -------------------------------------------------------------------------------- /mixscat/examples/fake.mac: -------------------------------------------------------------------------------- 1 | read 2 | cell cef3.cll,1,1,1 3 | 4 | pdf 5 | isel all 6 | jsel all 7 | 8 | set therm,gauss 9 | set bound,period 10 | set range,20.0,0.01 11 | set part,internal 12 | set dens,0.0 13 | set delt,0.0 14 | 15 | set rad,neutron 16 | show 17 | calc 18 | save pdf,CeF3_fake_N.gr 19 | 20 | set rad,xray 21 | show 22 | calc 23 | save pdf,CeF3_fake_X.gr 24 | 25 | exit 26 | -------------------------------------------------------------------------------- /mixscat/examples/p.mac: -------------------------------------------------------------------------------- 1 | reset 2 | load xy, CeCe_new_diff.gr 3 | load xy, cece.gr 4 | load xy, CeF_new_diff.gr 5 | load xy, cef.gr 6 | load xy, FF_new_diff.gr 7 | load xy, ff.gr 8 | 9 | r[1]=100./ymax[1] 10 | r[2]=100./ymax[3] 11 | r[3]=100./ymax[5] 12 | 13 | ccal mul,wy,1,r[1] 14 | ccal mul,wy,2,r[1] 15 | ccal mul,wy,3,r[2] 16 | ccal mul,wy,4,r[2] 17 | ccal mul,wy,5,r[3] 18 | ccal mul,wy,6,r[3] 19 | 20 | load ma, cece.ma 21 | load ma, cef.ma 22 | load ma, ff.ma 23 | 24 | fset 2 25 | grid off 26 | achx r(\A) 27 | achy \gD G(r) (\A\u-2\d) 28 | lcol 1,3 29 | lcol 2,1 30 | lcol 3,3 31 | lcol 4,1 32 | lcol 5,3 33 | lcol 6,1 34 | etyp 1,2 35 | etyp 3,2 36 | etyp 5,2 37 | ecol 1,3 38 | ecol 3,3 39 | ecol 5,3 40 | 41 | lwid 2,0.6 42 | lwid 4,0.6 43 | lwid 6,0.6 44 | mtyp 7,9 45 | mtyp 8,9 46 | mtyp 9,9 47 | msiz 7,0.3 48 | msiz 8,0.3 49 | msiz 9,0.3 50 | ccal add,wy,7,-60 51 | ccal add,wy,8,-65 52 | ccal add,wy,9,-70 53 | 54 | skal 0.5,9.9,-79.9,125 55 | mark 2,20 56 | 57 | fnam off 58 | sleg 2,DISCUS 59 | sleg 1,MIXSCA 60 | sleg 4,DISCUS 61 | sleg 3,MIXSCA 62 | sleg 6,DISCUS 63 | sleg 5,MIXSCA 64 | sleg 7,CeCe 65 | sleg 8,CeF 66 | sleg 9,FF 67 | 68 | nfra 3 69 | kfra 1,1,2,7,8,9 70 | kfra 2,3,4,7,8,9 71 | kfra 3,5,6,7,8,9 72 | 73 | afra 1 74 | buff 0.06,0.00,0.08,0.04 75 | tit2 Ce-Ce 76 | 77 | afra 2 78 | buff 0.03,0.03,0.08,0.04 79 | tit2 Ce-F 80 | achy OFF 81 | 82 | afra 3 83 | buff 0.00,0.06,0.08,0.04 84 | tit2 F-F 85 | achy OFF 86 | 87 | plot 88 | exit 89 | -------------------------------------------------------------------------------- /mixscat/examples/pdf.mac: -------------------------------------------------------------------------------- 1 | read 2 | cell cef3.cll,1,1,1 3 | 4 | pdf 5 | isel all 6 | jsel all 7 | 8 | set therm,gauss 9 | set bound,period 10 | set range,20.0,0.01 11 | set part,internal 12 | set dens,0.0 13 | set delt,0.0 14 | show 15 | calc 16 | save pdf,tot.gr 17 | 18 | @wn_CeCe 19 | show 20 | calc 21 | save pdf,cece.gr 22 | 23 | @wn_CeF 24 | show 25 | calc 26 | save pdf,cef.gr 27 | 28 | @wn_FF 29 | show 30 | calc 31 | save pdf,ff.gr 32 | exit 33 | exit 34 | -------------------------------------------------------------------------------- /mixscat/examples/pma.mac: -------------------------------------------------------------------------------- 1 | read 2 | cell cef3.cll,1,1,1 3 | 4 | pdf 5 | set therm,cryst 6 | set bound,period 7 | set part,internal 8 | set density,0.0 9 | set range,20.0,0.01 10 | 11 | isel all 12 | jsel all 13 | show 14 | calc 15 | save mark,tot.ma 16 | 17 | ides all 18 | jdes all 19 | isel ce 20 | jsel ce 21 | show 22 | calc 23 | save mark,cece.ma 24 | 25 | ides all 26 | jdes all 27 | isel ce 28 | jsel f 29 | show 30 | calc 31 | save mark,cef.ma 32 | 33 | ides all 34 | jdes all 35 | isel f 36 | jsel f 37 | show 38 | calc 39 | save mark,ff.ma 40 | exit 41 | -------------------------------------------------------------------------------- /mixscat/examples/test.mac: -------------------------------------------------------------------------------- 1 | reset 2 | read dat,x,CeF3_bulk_binned.gr 3 | read dat,n,CeF3_Bulk_npdf_03902.gr 4 | # 5 | # From PDFgui 6 | #scal 1,1.0/0.86 7 | #scal 2,1.0/13.5 8 | # 9 | match 0.5,2.0,24./320.864 10 | elem Ce,1,F,3 11 | # 12 | remove Ce,Ce 13 | show 14 | calc 15 | save pdf,CeCe_new_diff.gr 16 | save wei,w_CeCe.mac 17 | save res,CeCe.res 18 | # 19 | remove Ce,F 20 | show 21 | calc 22 | save pdf,CeF_new_diff.gr 23 | save wei,w_CeF.mac 24 | save res,CeF.res 25 | # 26 | remove F,F 27 | show 28 | calc 29 | save pdf,FF_new_diff.gr 30 | save wei,w_FF.mac 31 | save res,FF.res 32 | # 33 | system discus pdf > /dev/null 34 | system kuplot p > /dev/null 35 | -------------------------------------------------------------------------------- /mixscat/examples/w_CeCe.mac: -------------------------------------------------------------------------------- 1 | set partial,CE ,CE , 0.0000000 2 | set partial,CE ,F , 16.266106 3 | set partial,F ,F , 21.585993 4 | set rden, 18.241911 5 | -------------------------------------------------------------------------------- /mixscat/examples/w_CeF.mac: -------------------------------------------------------------------------------- 1 | set partial,CE ,CE , -29.810568 2 | set partial,CE ,F , 0.0000000 3 | set partial,F ,F , 5.4220338 4 | set rden, 1.1867342 5 | -------------------------------------------------------------------------------- /mixscat/examples/w_FF.mac: -------------------------------------------------------------------------------- 1 | set partial,CE ,CE , 72.501228 2 | set partial,CE ,F , 9.9368553 3 | set partial,F ,F , 0.0000000 4 | set rden, 8.2576466 5 | -------------------------------------------------------------------------------- /mixscat/examples/wn_CeCe.mac: -------------------------------------------------------------------------------- 1 | set partial,CE ,CE , 0.0000000 2 | set partial,CE ,F , 16.266106 3 | set partial,F ,F , 21.585993 4 | set rden, 18.241911 5 | -------------------------------------------------------------------------------- /mixscat/examples/wn_CeF.mac: -------------------------------------------------------------------------------- 1 | set partial,CE ,CE , -29.810568 2 | set partial,CE ,F , 0.0000000 3 | set partial,F ,F , 5.4220338 4 | set rden, 1.1867342 5 | -------------------------------------------------------------------------------- /mixscat/examples/wn_FF.mac: -------------------------------------------------------------------------------- 1 | set partial,CE ,CE , 72.501228 2 | set partial,CE ,F , 9.9368553 3 | set partial,F ,F , 0.0000000 4 | set rden, 8.2576466 5 | -------------------------------------------------------------------------------- /mixscat/prog/CMakeLists.txt: -------------------------------------------------------------------------------- 1 | # MIXSCAT Build 2 | 3 | include_directories(${DIFFUSE_SOURCE_DIR}/lib_f90) 4 | include_directories(${DIFFUSE_BINARY_DIR}/lib_f90) 5 | 6 | link_directories(${DIFFUSE_BINARY_DIR}/lib_f90) 7 | 8 | set (SOURCES blk_appl.f90 err_appl.f90 exit.f90 9 | fit.f90 kdo.f90 lazy.f load.f90 10 | mixscat.f90 save.f90 set.f90 show.f90 11 | upd_par.f90 weights.f90 12 | config_mod.f90 mixscat_mod.f90) 13 | 14 | add_executable(mixscat ${SOURCES}) 15 | target_link_libraries (mixscat lib_f90 lib_f90c ${DIFFUSE_LIBS}) 16 | 17 | add_custom_target(mixscathlp 18 | DEPENDS ${DIFFUSE_SOURCE_DIR}/mixscat/prog/appl_mix.hlp 19 | ${DIFFUSE_SOURCE_DIR}/lib_f90/lib_f90.hlp 20 | COMMAND cat ${DIFFUSE_SOURCE_DIR}/mixscat/prog/appl_mix.hlp 21 | ${DIFFUSE_SOURCE_DIR}/lib_f90/lib_f90.hlp > 22 | ${DIFFUSE_BINARY_DIR}/mixscat/prog/mixscat.hlp) 23 | 24 | add_dependencies(mixscat mixscathlp) 25 | 26 | install (TARGETS mixscat DESTINATION bin) 27 | install (FILES ${DIFFUSE_BINARY_DIR}/mixscat/prog/mixscat.hlp DESTINATION share) 28 | file(GLOB files "${DIFFUSE_SOURCE_DIR}/mixscat/prog/sysmac/*.mac") 29 | install (FILES ${files} DESTINATION share/mixscat) 30 | 31 | -------------------------------------------------------------------------------- /mixscat/prog/config_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE config_mod 2 | ! 3 | IMPLICIT NONE 4 | PUBLIC 5 | SAVE 6 | ! 7 | !####################################################################### 8 | ! MAXSCAT Configuration file 9 | !####################################################################### 10 | ! 11 | ! MAXDAT : Maximum number of PDF data points 12 | ! MAXDSET : Maximum number of PDF data sets 13 | ! MAXELEM : Maximum number of element 14 | ! MAXPARA : Maximum number of fit PARAMETERs 15 | ! 16 | !####################################################################### 17 | ! 18 | INTEGER, PARAMETER :: MAXDAT = 10010 19 | INTEGER, PARAMETER :: MAXDSET = 2 20 | INTEGER, PARAMETER :: MAXELEM = 20 21 | INTEGER, PARAMETER :: MAXPARA = 2 22 | ! 23 | ! 24 | END MODULE config_mod 25 | -------------------------------------------------------------------------------- /mixscat/prog/exit.f90: -------------------------------------------------------------------------------- 1 | SUBROUTINE mixscat_do_exit 2 | ! 3 | USE exit_mod 4 | USE prompt_mod 5 | ! 6 | IMPLICIT none 7 | ! 8 | CALL exit_all 9 | END SUBROUTINE mixscat_do_exit 10 | -------------------------------------------------------------------------------- /mixscat/prog/sysmac/systest.mac: -------------------------------------------------------------------------------- 1 | set prompt,off,off,save 2 | echo "MIXSCAT system macros seem to work ..." 3 | set prompt,old 4 | -------------------------------------------------------------------------------- /python/Notebooks/demo.mac: -------------------------------------------------------------------------------- 1 | do i[1]=1,5 2 | r[i[1]]=i[1]/5.0 3 | enddo 4 | echo "Done .." -------------------------------------------------------------------------------- /python/Notebooks/one.mac: -------------------------------------------------------------------------------- 1 | discus 2 | variable integer,test 3 | test=123 4 | exit 5 | 6 | -------------------------------------------------------------------------------- /python/Notebooks/plot3d.mac: -------------------------------------------------------------------------------- 1 | kuplot 2 | reset 3 | func sin(r[0])*cos(r[1]),0,6,0.1,0,6,0.1 4 | exit 5 | -------------------------------------------------------------------------------- /python/Notebooks/pow.py: -------------------------------------------------------------------------------- 1 | import sys 2 | #sys.path.append('/home/discus/DiffuseBuilt/python') 3 | sys.path.append('/usr/local/lib') # Find an installation location (/usr/local/lib or python default path) 4 | 5 | from suite_python import suite as s 6 | import numpy as np 7 | 8 | s.initialize_suite() 9 | s.execute_macro("@powder.mac") 10 | 11 | n=200 12 | x=np.empty(n, dtype=np.float32) 13 | y=np.empty(n, dtype=np.float32) 14 | s.get_data(x,y,n) 15 | 16 | rnumbers=np.empty(4, dtype=np.float32) 17 | s.get_r(rnumbers,1,4) 18 | 19 | print(rnumbers) 20 | print(x) 21 | print(y) 22 | 23 | s.execute_macro("@test.mac") 24 | 25 | -------------------------------------------------------------------------------- /python/Notebooks/powder.mac: -------------------------------------------------------------------------------- 1 | set prompt,off,off 2 | discus 3 | read 4 | cell primitive.cell,20,20,20 5 | # 6 | powder # Switch to powder menu 7 | reset 8 | $1 # Select radiation 9 | set axis,q # Perform calculation on equaly spaced Q grid 10 | set calc,debye # Use Debye-algorithm 11 | set disp,off # Switch anomalous dispersion off 12 | set delta,0.0 # Set simple convolution by Gaussian off 13 | set qmin,0.500 # Starting value for Q 14 | set qmax,7.100 # Final value for Q 15 | set dq, 0.005 # Step size for Q 16 | set profile, off # Switch convolution by Pseudovoigt function off 17 | set temp,use # Use the Atomic displacement parameters 18 | set wvle,1.54056 # Set the wavelength 19 | set four,four # Just for stacking fault mode, set to normal 20 | #set lpcor,bragg,26.58 # Define Lorentz-Pol to BraggBrentano Diffractometer 21 | show 22 | run # Do the actual calculation 23 | exit # Go back to main DISCUS menu 24 | # 25 | output # Switch to output menu 26 | outf kuplot.inte # Define output file name 27 | value inte # Select intensity as output value 28 | form powder,tth,1.0,120,0.02 # Write output as powder data 29 | run # Perform the actual output 30 | exit # Go back to main DISCUS menu 31 | exit 32 | -------------------------------------------------------------------------------- /python/Notebooks/primitive.cell: -------------------------------------------------------------------------------- 1 | title primitive 2 | spcgr Pm-3m 3 | cell 3.523400 3.523400 3.523400 90.000000 90.000000 90.000000 4 | atoms 5 | Pb 0.000000 0.000000 0.000000 0.2000 6 | -------------------------------------------------------------------------------- /python/Notebooks/test.py: -------------------------------------------------------------------------------- 1 | import sys 2 | sys.path.append('/home/discus/DiffuseBuilt/python') 3 | sys.path.append('/usr/local/lib') # Find an installation location (/usr/local/lib or python default path) 4 | 5 | from suite_python import suite as s 6 | import numpy as np 7 | 8 | s.initialize_suite() 9 | s.execute_macro("@one.mac") 10 | s.execute_macro("@two.mac") 11 | -------------------------------------------------------------------------------- /python/Notebooks/two.mac: -------------------------------------------------------------------------------- 1 | eval test 2 | echo "Woohoo" 3 | -------------------------------------------------------------------------------- /python/Notebooks/vartest.mac: -------------------------------------------------------------------------------- 1 | variable real, dummy 2 | dummy = 3.1415 3 | 4 | variable real, array, dim:[10] 5 | array[1]=-2.3 6 | -------------------------------------------------------------------------------- /refine/prog/refine_branch.f90: -------------------------------------------------------------------------------- 1 | SUBROUTINE refine_branch(zeile, length, lreset, lloop) 2 | ! 3 | ! Specific REFINE Version of a branch subroutine 4 | ! Call DISCUS/KUPLOT via system 5 | ! Currently this gives an error message in a stand alone 6 | ! program 7 | ! 8 | USE errlist_mod 9 | ! 10 | IMPLICIT NONE 11 | ! 12 | CHARACTER (LEN=*), INTENT(IN) :: zeile 13 | INTEGER , INTENT(IN) :: length 14 | LOGICAL , INTENT(IN) :: lreset 15 | integer , INTENT(IN) :: lloop 16 | ! 17 | ier_num = -7 18 | ier_typ = ER_COMM 19 | ! 20 | END SUBROUTINE refine_branch 21 | -------------------------------------------------------------------------------- /refine/prog/refine_current.f90: -------------------------------------------------------------------------------- 1 | MODULE refine_current_mod 2 | ! 3 | CONTAINS 4 | ! 5 | SUBROUTINE refine_current_all 6 | !- 7 | ! Calculate current parameter values refined and fixed 8 | !+ 9 | USE refine_params_mod 10 | ! 11 | IMPLICIT NONE 12 | ! 13 | CALL refine_current(refine_par_n, refine_params, refine_p) 14 | CALL refine_current(refine_fix_n, refine_fixed , refine_f) 15 | ! 16 | END SUBROUTINE refine_current_all 17 | ! 18 | !******************************************************************************* 19 | ! 20 | SUBROUTINE refine_current(par_n, params, p) 21 | !- 22 | ! Calculate current parameter values refined or fixed 23 | !+ 24 | USE ber_params_mod 25 | USE precision_mod 26 | ! 27 | IMPLICIT NONE 28 | ! 29 | INTEGER , INTENT(IN) :: par_n 30 | CHARACTER(LEN=*) , DIMENSION(1:par_n), INTENT(IN) :: params 31 | REAL(KIND=PREC_DP), DIMENSION(1:par_n), INTENT(OUT) :: p 32 | ! 33 | CHARACTER(LEN=MAX(PREC_STRING,LEN(params))), DIMENSION(:), ALLOCATABLE :: cpara 34 | INTEGER , DIMENSION(:), ALLOCATABLE :: lpara 35 | REAL(KIND=PREC_DP) , DIMENSION(:), ALLOCATABLE :: werte 36 | INTEGER :: k 37 | INTEGER :: ianz 38 | INTEGER :: MAXW 39 | ! 40 | ! Calculate current parameter values 41 | ! 42 | ALLOCATE(cpara(1:par_n)) 43 | ALLOCATE(lpara(1:par_n)) 44 | ALLOCATE(werte(1:par_n)) 45 | DO k=1, par_n 46 | cpara(k) = params(k) 47 | lpara(k) = LEN_TRIM(params(k)) 48 | ENDDO 49 | ianz = par_n 50 | MAXW = par_n 51 | CALL ber_params(ianz, cpara, lpara, werte, MAXW) 52 | DO k=1, par_n 53 | p(k) = werte(k) 54 | ENDDO 55 | DEALLOCATE(cpara) 56 | DEALLOCATE(lpara) 57 | DEALLOCATE(werte) 58 | ! 59 | END SUBROUTINE refine_current 60 | ! 61 | !******************************************************************************* 62 | ! 63 | END MODULE refine_current_mod 64 | -------------------------------------------------------------------------------- /refine/prog/refine_data_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE refine_data_mod 2 | ! 3 | USE precision_mod 4 | ! 5 | IMPLICIT NONE 6 | ! 7 | CHARACTER(LEN=PREC_STRING) :: ref_load_u = ' ' ! Load string data 8 | CHARACTER(LEN=PREC_STRING) :: ref_csigma_u = ' ' ! Load string Sigma's 9 | CHARACTER(LEN=PREC_STRING) :: ref_load = ' ' ! Load string data 10 | CHARACTER(LEN=PREC_STRING) :: ref_csigma = ' ' ! Load string Sigma's 11 | INTEGER :: ref_kload = 0 ! Data set within KUPLOT 12 | INTEGER :: ref_ksigma= 0 ! Sigma set within KUPLOT 13 | INTEGER :: ref_kupl = 0 ! Data set within KUPLOT that needs to be kept 14 | INTEGER :: ref_type = 0 ! Data type => lib_data_types_mod 15 | INTEGER , DIMENSION(3) :: ref_dim ! Dimensions of data set 16 | REAL(kind=PREC_DP) , DIMENSION(:,:,:), ALLOCATABLE :: ref_data ! the actual data set 17 | REAL(kind=PREC_DP) , DIMENSION(:,:,:), ALLOCATABLE :: ref_sigma ! sigma at each data point 18 | REAL(kind=PREC_DP) , DIMENSION(: ), ALLOCATABLE :: ref_x ! x-values of data set 19 | REAL(kind=PREC_DP) , DIMENSION(: ), ALLOCATABLE :: ref_y ! y-values of data set 20 | REAL(kind=PREC_DP) , DIMENSION(: ), ALLOCATABLE :: ref_z ! z-values of data set 21 | ! 22 | END MODULE refine_data_mod 23 | -------------------------------------------------------------------------------- /refine/prog/refine_do_exit.f90: -------------------------------------------------------------------------------- 1 | MODULE refine_do_exit_mod 2 | ! 3 | CONTAINS 4 | ! 5 | SUBROUTINE refine_do_exit 6 | ! 7 | USE refine_allocate_appl 8 | ! 9 | USE exit_mod 10 | USE prompt_mod 11 | !+ 12 | ! Clean exit from the program REFINE ;-) 13 | !- 14 | IMPLICIT none 15 | INTEGER :: length 16 | ! 17 | ! 18 | length = 3 19 | CALL refine_do_deallocate_appl ( 'all',length) 20 | CALL exit_all 21 | ! 22 | IF (output_io.ne.OUTPUT_SCREEN) THEN 23 | CLOSE (output_io) 24 | ENDIF 25 | ! 26 | END SUBROUTINE refine_do_exit 27 | ! 28 | SUBROUTINE refine_emergency_save 29 | ! 30 | ! Write the GENERATION , PARAMETER SUMMARY files 31 | ! Currently left blank intentionally, as these 32 | ! Files are updated regularly at points where it 33 | ! makes sense to update them 34 | ! 35 | IMPLICIT NONE 36 | ! 37 | !WRITE(*,*) ' SAVING STRUCTURE TO EMERGENCY.STRU ' 38 | ! 39 | ! 40 | END SUBROUTINE refine_emergency_save 41 | ! 42 | SUBROUTINE refine_emergency_mpi 43 | ! 44 | ! Closes down MPI in case of emergency. 45 | ! Currently just a finalize, to be developed further 46 | ! 47 | USE diffev_mpi_mod 48 | IMPLICIT NONE 49 | ! 50 | CALL run_mpi_finalize 51 | ! 52 | ! 53 | END SUBROUTINE refine_emergency_mpi 54 | ! 55 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 56 | ! 57 | END MODULE refine_do_exit_mod 58 | -------------------------------------------------------------------------------- /refine/prog/refine_err_appl.f90: -------------------------------------------------------------------------------- 1 | module refine_errlist_mod 2 | ! 3 | contains 4 | !*****7**************************************************************** 5 | ! 6 | SUBROUTINE refine_errlist_appl 7 | !- 8 | ! Displays error Messages for the error type APPLication 9 | !+ 10 | USE errlist_mod 11 | USE lib_errlist_func 12 | ! 13 | IMPLICIT none 14 | ! 15 | INTEGER iu,io 16 | PARAMETER (IU=-13,IO=0) 17 | ! 18 | CHARACTER(LEN=45) ERROR(IU:IO) 19 | ! 20 | ! 21 | DATA ERROR ( IU: 0) / & 22 | & 'Unknown prameter name, check list of newpara', & ! -13 ! refine 23 | & 'COVAR not allocated, run a refinement first ', & ! -12 ! refine 24 | & 'Parameter(s) outside range/constrain ', & ! -11 ! refine 25 | & 'FWHM parameter give negative FWHM ', & ! -10 ! refine 26 | & 'Calculation of derivatives failed ', & ! -9 ! refine 27 | & 'points is limited to 3 or 5 ', & ! -8 ! refine 28 | & 'Sigma in data set are zero ', & ! -7 ! refine 29 | & 'An error occurred in the user macro ', & ! -6 ! refine 30 | & 'Data set must be loaded prior to sigma ', & ! -5 ! refine 31 | & 'Dimensions of calc. and observed data differ', & ! -4 ! refine 32 | & 'Data not present within KUPLOT', & ! -3 ! refine 33 | & 'Macro file does not exist', & ! -2 ! refine 34 | & 'Data dimensions have not yet been defined', & ! -1 ! refine 35 | & ' ' & ! 0 ! refine 36 | & / 37 | ! 38 | CALL disp_error ('APPL',error,iu,io) 39 | ! 40 | END SUBROUTINE refine_errlist_appl 41 | ! 42 | !*****7**************************************************************** 43 | end module refine_errlist_mod 44 | -------------------------------------------------------------------------------- /refine/prog/refine_fit_erg.f90: -------------------------------------------------------------------------------- 1 | MODULE refine_fit_erg 2 | ! 3 | use precision_mod 4 | IMPLICIT NONE 5 | ! 6 | REAL(kind=PREC_DP) :: refine_chisqr = -1.0 ! Sum of dev^2 in previous cycle 7 | REAL(kind=PREC_DP) :: refine_conf = -1.0 ! sum of dev^2 8 | REAL(kind=PREC_DP) :: refine_lamda = -1.0 ! Final convergence criterion 9 | REAL(kind=PREC_DP) :: refine_rval = -1.0 ! weighted R-value 10 | REAL(kind=PREC_DP) :: refine_rexp = -1.0 ! unweighted R-value 11 | ! 12 | END MODULE refine_fit_erg 13 | -------------------------------------------------------------------------------- /refine/prog/refine_fit_set_sub_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE refine_fit_set_sub_mod 2 | ! 3 | CONTAINS 4 | ! 5 | !******************************************************************************* 6 | ! 7 | SUBROUTINE refine_fit_set_sub 8 | ! 9 | USE set_sub_generic_mod 10 | ! 11 | IMPLICIT NONE 12 | ! 13 | INTERFACE 14 | SUBROUTINE refine_fit_mache_kdo (line, lend, length) 15 | ! 16 | CHARACTER (LEN= * ), INTENT(INOUT) :: line 17 | LOGICAL , INTENT( OUT) :: lend 18 | INTEGER , INTENT(INOUT) :: length 19 | ! 20 | END SUBROUTINE refine_fit_mache_kdo 21 | END INTERFACE 22 | ! 23 | p_mache_kdo => refine_fit_mache_kdo 24 | ! 25 | END SUBROUTINE refine_fit_set_sub 26 | ! 27 | !******************************************************************************* 28 | ! 29 | SUBROUTINE refine_fit_un_sub 30 | ! 31 | USE set_sub_generic_mod 32 | ! 33 | IMPLICIT NONE 34 | ! 35 | INTERFACE 36 | SUBROUTINE refine_mache_kdo (line, lend, length) 37 | ! 38 | CHARACTER (LEN= * ), INTENT(INOUT) :: line 39 | LOGICAL , INTENT( OUT) :: lend 40 | INTEGER , INTENT(INOUT) :: length 41 | ! 42 | END SUBROUTINE refine_mache_kdo 43 | END INTERFACE 44 | ! 45 | p_mache_kdo => refine_mache_kdo 46 | ! 47 | END SUBROUTINE refine_fit_un_sub 48 | ! 49 | !******************************************************************************* 50 | ! 51 | END MODULE refine_fit_set_sub_mod 52 | -------------------------------------------------------------------------------- /refine/prog/refine_log_mod.f90: -------------------------------------------------------------------------------- 1 | module refine_log_mod 2 | ! 3 | ! Kep/retain log file for MPI driven refinements 4 | ! 5 | logical :: refine_log = .false.! Keep LOGFILES after exit 6 | ! 7 | end module refine_log_mod 8 | -------------------------------------------------------------------------------- /refine/prog/refine_loop_mpi.f90: -------------------------------------------------------------------------------- 1 | SUBROUTINE refine_loop_mpi(prog_n, prog_l, mac_n, mac_l, out_n, out_l, repeat, nindiv) 2 | ! 3 | ! This routine is called if a "run_mpi" command occurs within a do loop or 4 | ! if block and we are running discus_suite without MPI active. 5 | ! 6 | ! Copies the run_mpi parameters detected from a "run_mpi" within a loop 7 | ! into the senddata structure. 8 | ! 9 | USE run_mpi_mod 10 | ! 11 | IMPLICIT NONE 12 | ! 13 | CHARACTER (LEN=*), INTENT(IN) :: prog_n 14 | CHARACTER (LEN=*), INTENT(IN) :: mac_n 15 | CHARACTER (LEN=*), INTENT(IN) :: out_n 16 | INTEGER , INTENT(IN) :: prog_l 17 | INTEGER , INTENT(IN) :: mac_l 18 | INTEGER , INTENT(IN) :: out_l 19 | LOGICAL , INTENT(IN) :: repeat 20 | INTEGER , INTENT(IN) :: nindiv 21 | ! 22 | !run_mpi_senddata%prog = prog_n 23 | !run_mpi_senddata%prog_l = prog_l 24 | !run_mpi_senddata%mac = mac_n 25 | !run_mpi_senddata%mac_l = mac_l 26 | !run_mpi_senddata%out = out_n 27 | !run_mpi_senddata%out_l = out_l 28 | !run_mpi_senddata%repeat = repeat 29 | !run_mpi_senddata%nindiv = nindiv 30 | ! 31 | !run_mpi_senddata%generation = pop_gen ! Current GENERATION no 32 | !run_mpi_senddata%member = pop_n ! Number of members 33 | !run_mpi_senddata%children = pop_c ! Number of children 34 | !run_mpi_senddata%parameters = pop_dimx ! Number of parameters 35 | !run_mpi_senddata%use_socket = .false. 36 | ! 37 | !run_mpi_senddata%l_get_state = l_get_random_state 38 | ! 39 | END SUBROUTINE refine_loop_mpi 40 | -------------------------------------------------------------------------------- /refine/prog/refine_mac_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE refine_mac_mod 2 | ! 3 | USE precision_mod 4 | ! 5 | CHARACTER(LEN=PREC_STRING) :: refine_mac ! Refinement user macro name 6 | CHARACTER(LEN=PREC_STRING) :: refine_plot_mac ! Refinement user interactive plot macro name 7 | INTEGER :: refine_mac_l ! Length of character string for macro 8 | ! 9 | END MODULE refine_mac_mod 10 | -------------------------------------------------------------------------------- /refine/prog/refine_random_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE refine_random_mod 2 | ! 3 | ! Handles the random state 4 | ! 5 | ! Needed to ensure that all callc to the macro for the derivatives use the 6 | ! same set of random seeds at startup. 7 | ! 8 | INTEGER :: refine_nseed 9 | INTEGER, DIMENSION(0:64) :: refine_seeds ! Current seeds 10 | ! 11 | CONTAINS 12 | ! 13 | !******************************************************************************* 14 | ! 15 | SUBROUTINE refine_save_seeds 16 | !- 17 | ! Get and save the current seeds 18 | !+ 19 | ! 20 | USE random_state_mod 21 | IMPLICIT NONE 22 | ! 23 | refine_nseed = random_nseeds() 24 | ! 25 | CALL random_current(refine_nseed, refine_seeds) 26 | !CALL random_current(refine_seeds) 27 | ! 28 | END SUBROUTINE refine_save_seeds 29 | ! 30 | !******************************************************************************* 31 | ! 32 | SUBROUTINE refine_restore_seeds 33 | !- 34 | ! Get and save the current seeds 35 | !+ 36 | ! 37 | USE random_state_mod 38 | IMPLICIT NONE 39 | ! 40 | CALL put_seeds(refine_nseed, refine_seeds) 41 | ! 42 | END SUBROUTINE refine_restore_seeds 43 | ! 44 | !******************************************************************************* 45 | ! 46 | END MODULE refine_random_mod 47 | -------------------------------------------------------------------------------- /refine/prog/refine_run_mpi_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE refine_run_mpi_mod 2 | ! 3 | IMPLICIT NONE 4 | ! 5 | INTEGER :: ref_run_mpi_myid 6 | INTEGER :: ref_run_mpi_numprocs 7 | ! 8 | END MODULE refine_run_mpi_mod 9 | -------------------------------------------------------------------------------- /refine/prog/refine_set_param.f90: -------------------------------------------------------------------------------- 1 | MODULE refine_set_param_mod 2 | ! 3 | CONTAINS 4 | ! 5 | !******************************************************************************* 6 | ! 7 | SUBROUTINE refine_set_param(npara, params, k, wert) 8 | ! 9 | USE calc_expr_mod 10 | USE precision_mod 11 | ! 12 | IMPLICIT NONE 13 | ! 14 | INTEGER , INTENT(IN) :: npara ! Number of parameters 15 | CHARACTER(LEN=*) , INTENT(IN) :: params ! Parameter names 16 | INTEGER , INTENT(IN) :: k ! number to be updated 17 | REAL(kind=PREC_DP) , INTENT(IN) :: wert ! Target value 18 | ! 19 | CHARACTER(LEN=PREC_STRING) :: string ! dumy string variable 20 | INTEGER :: lpname ! Length of a parameter name 21 | INTEGER :: indxg ! Location of "=" in string 22 | INTEGER :: length ! Length of a string 23 | ! 24 | lpname = LEN_TRIM(params) 25 | WRITE(string,'(a,a,G20.12E3)') params(1:lpname), ' = ', wert 26 | indxg = lpname + 2 27 | length = LEN_TRIM(string) 28 | ! 29 | CALL do_math (string, indxg, length) 30 | ! 31 | END SUBROUTINE refine_set_param 32 | ! 33 | !******************************************************************************* 34 | ! 35 | END MODULE refine_set_param_mod 36 | -------------------------------------------------------------------------------- /refine/prog/sysmac/systest.mac: -------------------------------------------------------------------------------- 1 | set prompt,off,on,save 2 | # 3 | # $Id: systest.mac,v 1.1.1.1 2012/06/09 16:18:24 rbneder Exp $ 4 | # 5 | echo "REFINE system macros seem to work ..." 6 | set prompt,old 7 | -------------------------------------------------------------------------------- /scripts/MACconfig.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | echo "# Modified by Diffuse Install on `date`" >> ${HOME}/.profile 4 | echo "source /usr/local/discus/share/setup.sh" >> ${HOME}/.profile 5 | echo "# End modification by Diffuse Install" >> ${HOME}/.profile 6 | -------------------------------------------------------------------------------- /scripts/setup.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | echo "Setting up DISCUS environment .." 4 | 5 | export PATH=$PATH:/usr/local/discus/bin 6 | export PGPLOT_DIR=/usr/local/discus/share 7 | export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:/usr/local/discus/lib 8 | -------------------------------------------------------------------------------- /suite/prog/suite_err_appl.f90: -------------------------------------------------------------------------------- 1 | MODULE suite_errlist_func 2 | ! 3 | CONTAINS 4 | ! 5 | !*****7**************************************************************** 6 | ! 7 | SUBROUTINE suite_errlist_appl 8 | !- 9 | ! Displays error Messages for the error type APPLication 10 | !+ 11 | USE errlist_mod 12 | USE lib_errlist_func 13 | IMPLICIT none 14 | ! 15 | ! 16 | INTEGER iu,io 17 | PARAMETER (IU= 0,IO=0) 18 | ! 19 | CHARACTER(LEN=45) ERROR(IU:IO) 20 | ! 21 | DATA ERROR ( 0: 0) / & 22 | & ' ' & ! 0 ! diffev 23 | & / 24 | ! 25 | CALL disp_error ('APPL',error,iu,io) 26 | ! 27 | END SUBROUTINE suite_errlist_appl 28 | ! 29 | !*****7**************************************************************** 30 | ! 31 | END MODULE suite_errlist_func 32 | -------------------------------------------------------------------------------- /suite/prog/suite_exit.f90: -------------------------------------------------------------------------------- 1 | MODULE do_exit_mod 2 | ! 3 | CONTAINS 4 | ! 5 | !******************************************************************************* 6 | ! 7 | SUBROUTINE do_exit 8 | !- 9 | ! Generic exit from discsu_suite 10 | !+ 11 | !USE allocate_appl 12 | USE discus_plot_menu, ONLY:jmol_kill 13 | USE exit_mod 14 | USE prompt_mod 15 | !+ 16 | ! Clean exit from the program DIFFEV ;-) 17 | !- 18 | IMPLICIT none 19 | ! 20 | ! Terminate any Jmol processes started by this discus_suite 21 | ! 22 | CALL jmol_kill(.FALSE., .TRUE.) 23 | ! 24 | !CALL do_deallocate_appl ( 'all',3) 25 | CALL exit_all 26 | ! 27 | IF (output_status.ne.OUTPUT_SCREEN) then 28 | CLOSE (output_io) 29 | ENDIF 30 | ! 31 | END SUBROUTINE do_exit 32 | ! 33 | !******************************************************************************* 34 | ! 35 | END MODULE do_exit_mod 36 | -------------------------------------------------------------------------------- /suite/prog/suite_init_mod.f90: -------------------------------------------------------------------------------- 1 | MODULE suite_init_mod 2 | ! 3 | LOGICAL :: suite_diffev_init = .false. 4 | LOGICAL :: suite_discus_init = .false. 5 | LOGICAL :: suite_experi_init = .false. 6 | LOGICAL :: suite_kuplot_init = .false. 7 | LOGICAL :: suite_refine_init = .false. 8 | ! 9 | END MODULE suite_init_mod 10 | -------------------------------------------------------------------------------- /suite/prog/sysmac/systest.mac: -------------------------------------------------------------------------------- 1 | set prompt,off,on,save 2 | # 3 | # $Id: systest.mac,v 1.1.1.1 2012/06/09 16:18:24 rbneder Exp $ 4 | # 5 | echo "SUITE system macros seem to work ..." 6 | set prompt,old 7 | -------------------------------------------------------------------------------- /tools/convert2f90: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | echo 3 | echo $1 4 | echo 5 | /usr/local/bin/f2f90 << EOF 6 | $1 7 | 3 10 T F 8 | EOF 9 | -------------------------------------------------------------------------------- /tools/convert_inc2f90: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | echo 3 | echo $1 4 | echo 5 | cp $1.inc dummy.f 6 | /usr/local/bin/f2f90 << EOF 7 | dummy 8 | 3 10 T F 9 | EOF 10 | cp dummy.f90 $1.inc 11 | -------------------------------------------------------------------------------- /tools/create_dependency_list: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | mkdir -p DEPENDENCIES 4 | rm -f DEPENDENCIES/*.use 5 | rm -f DEPENDENCIES/00.DEP 6 | 7 | # 8 | for i in *.f90 9 | do 10 | rm -f DEPENDENCIES/$i.use 11 | fgrep include $i >> DEPENDENCIES/$i.use 12 | fgrep USE $i >> DEPENDENCIES/$i.use 13 | done 14 | cd DEPENDENCIES 15 | ls *.use > 00.DEP 16 | cp ../../../tools/make_dep.f90 . 17 | gfortran -o make_dep make_dep.f90 18 | ./make_dep 19 | cd .. 20 | rm -f DEPENDENCIES/*.use 21 | rm -f DEPENDENCIES/00.DEP 22 | rm -f DEPENDENCIES/make_dep* 23 | -------------------------------------------------------------------------------- /tools/make_dep: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tproffen/DiffuseCode/cafd7934ec4e96d3feadafb99c8d0ecce43de3c1/tools/make_dep -------------------------------------------------------------------------------- /tools/makedep.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | @f90files=glob("*.f90"); 4 | for ($i=0; $i<=$#f90files; $i++) { 5 | $useline=`grep USE $f90files[$i]`; 6 | @lines=split(/\n/,$useline); 7 | $out=""; 8 | for ($j=0; $j<=$#lines; $j++) { 9 | if ($lines[$j]=~/^\s*USE/) { 10 | $lines[$j]=~s/^\s*USE\s*//; 11 | $lines[$j]=~s/\s*$//; 12 | unless (-r "$lines[$j].f90") { 13 | $lines[$j]="../../lib_f90/$lines[$j]"; 14 | } 15 | unless ($out=~/$lines[$j]/) { 16 | $out.=$lines[$j]; 17 | $out.=".mod "; 18 | } 19 | } 20 | } 21 | 22 | if ($out) { print "$f90files[$i]: $out\n"; } 23 | } 24 | -------------------------------------------------------------------------------- /tools/substitute_end_inc: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | for i in *.inc 4 | do 5 | sed "s/ END/ /" $i > dummy 6 | mv dummy $i 7 | done 8 | 9 | -------------------------------------------------------------------------------- /tools/substitute_inc: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | for i in *.inc 4 | do 5 | sed "s/c------ /\! /g" $i > dummy 6 | mv dummy $i 7 | done 8 | for i in *.inc 9 | do 10 | sed "s/C------ /\!-----/g" $i > dummy 11 | mv dummy $i 12 | done 13 | for i in *.inc 14 | do 15 | sed "s/c /\! /g" $i > dummy 16 | mv dummy $i 17 | done 18 | for i in *.inc 19 | do 20 | sed "s/C /\! /g" $i > dummy 21 | mv dummy $i 22 | done 23 | for i in *.inc 24 | do 25 | sed "s/& /& /g" $i > dummy 26 | mv dummy $i 27 | done 28 | for i in *.inc 29 | do 30 | sed "s/ / /g" $i > dummy 31 | mv dummy $i 32 | done 33 | for i in *.inc 34 | do 35 | sed "s/c-/\!-/g" $i > dummy 36 | mv dummy $i 37 | done 38 | # 39 | for i in *.inc 40 | do 41 | sed "s/c+/\!+/g" $i > dummy 42 | mv dummy $i 43 | done 44 | # 45 | for i in *.inc 46 | do 47 | sed "s/real/REAL/g" $i > dummy 48 | mv dummy $i 49 | done 50 | # 51 | for i in *.inc 52 | do 53 | sed "s/integer/INTEGER/g" $i > dummy 54 | mv dummy $i 55 | done 56 | # 57 | for i in *.inc 58 | do 59 | sed "s/parameter/PARAMETER/g" $i > dummy 60 | mv dummy $i 61 | done 62 | # 63 | for i in *.inc 64 | do 65 | sed "s/logical/LOGICAL/g" $i > dummy 66 | mv dummy $i 67 | done 68 | # 69 | for i in *.inc 70 | do 71 | sed "s/character/CHARACTER/g" $i > dummy 72 | mv dummy $i 73 | done 74 | # 75 | for i in *.inc 76 | do 77 | sed "s/common/COMMON/g" $i > dummy 78 | mv dummy $i 79 | done 80 | -------------------------------------------------------------------------------- /tools/substitute_keywords: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | for i in *.f90 4 | do 5 | sed "s/else/ELSE/g" $i > dummy 6 | mv dummy $i 7 | done 8 | rm -f dummy 9 | --------------------------------------------------------------------------------